packages feed

yesod-core 1.6.14 → 1.7.0.0

raw patch · 151 files changed

Files

ChangeLog.md view
@@ -1,5 +1,192 @@ # ChangeLog for yesod-core +## 1.7.0.0++* Split route compilation ([#1887](https://github.com/yesodweb/yesod/pull/1887), [guide](https://github.com/yesodweb/yesod/blob/master/yesod-core/docs/split-route-compilation.md)):+    * Use `setFocusOnNestedRoute` to generate a nested route block's types and dispatch in their own module — for top-level sites, subsites, and parameterized foundations (`data App a`).+    * `setNestedRouteFallthrough` lets a nested parent with no matching child fall through to later sibling routes instead of committing to a 404.+    * Nested route fragments work in `redirect`/`setUrl`: wrap them in `WithParentArgs`, or use the bare constructor when the parent binds no dynamic pieces.+    * `mkNestedSubDispatchInstance` (for hand-written split subsite modules) takes resources as `[ResourceTree String]` — the `parseRoutes` quasi-quoter's output — and parses the type strings internally. No `map (fmap (parseType . dropBracket))` step, and a malformed type fails the splice with an attributable error.+    * Clearer TH errors for malformed route blocks, subsite/nested-datatype arity mismatches, and missing focus targets.+    * Breaking: modules that splice a nested route block need `MultiParamTypeClasses` (and usually `FlexibleContexts`).+    * Breaking: TH codegen entry points changed (`TyArgs` threading; `mkDispatchClause`, `mkParseRouteInstance`, `mkRouteConsOpts`, `mkDispatchInstance`); `mkRenderRouteClauses` and the `MkRouteOpts` constructor are no longer exported.+* `ResourceParent` records the parent's own route attributes; `frParentDetails` replaces `frParentPieces`. [#1911](https://github.com/yesodweb/yesod/pull/1911)++## 1.6.29.1++* Fix compilation error for text >= 2.1.2 [#1905](https://github.com/yesodweb/yesod/pull/1905)++## 1.6.29.0++* When showing HandlerContent, include a content snippet [#1864](https://github.com/yesodweb/yesod/pull/1864)++## 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)++## 1.6.27.1++* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876)++## 1.6.27.0++* Build with `wai-extra-3.1.17` [#1861](https://github.com/yesodweb/yesod/pull/1861)++## 1.6.26.0++* Always apply jsAttributes to julius script blocks of body [#1836](https://github.com/yesodweb/yesod/pull/1836)++## 1.6.25.1++* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825)++## 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.6.24.4++* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812)++## 1.6.24.3++* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805)++## 1.6.24.2++* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)++## 1.6.24.1++* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796)++## 1.6.24.0++* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772).++## 1.6.23.1++* Fix typo in creation of the description `<meta>` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766)++## 1.6.23++* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions+  have odd behaviour when called multiple times, so they are now warned against.+  This can't be a silent change - if you want to switch to the new functions, make+  sure your layouts are updated to use `pageDescription` as well as `pageTitle`.+  [#1765](https://github.com/yesodweb/yesod/pull/1765)++## 1.6.22.1+++ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756)++## 1.6.22.0++* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745)+* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752)+* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753)+* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754)++## 1.6.21.0++* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734)++## 1.6.20.2++* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729)++## 1.6.20.1++* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727)++## 1.6.20++* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726)+* Change semantics of `yreGen` and `defaultGen`++## 1.6.19.0++* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721)++## 1.6.18.8++* Fix test suite for wai-extra change around vary header++## 1.6.18.7++* Fix functions generating Open Graph metadata[#1709](https://github.com/yesodweb/yesod/pull/1709)++## 1.6.18.6++* Update documentation from `HandlerT` to `HandlerFor` [#1703](https://github.com/yesodweb/yesod/pull/1703)++## 1.6.18.5++Document `ErrorResponse` [#1698](https://github.com/yesodweb/yesod/pull/1698)++## 1.6.18.4++* Fixed a bug where `mkYesod` and other TH functions didn't work for datatypes with explicitly stated type variables, including the case with typeclass constraints. [https://github.com/yesodweb/yesod/pull/1697](#1697)++## 1.6.18.3++* Remove mention of an oudated Yesod type (`GHandler`) from the docs for `handlerToIO`. [https://github.com/yesodweb/yesod/pull/1695](#1695)++## 1.6.18.2++* Recommends `.yesodroutes` as the file extension for Yesod routes files. [#1686](https://github.com/yesodweb/yesod/pull/1686)++## 1.6.18.1++* Increase the size of CSRF token++## 1.6.18++* Add functions for setting description and OG meta [#1663](https://github.com/yesodweb/yesod/pull/1663)++* Use `DeriveLift` to implement the `Lift` instances for `ResourceTree`,+  `Resource`, `Piece`, and `Dispatch`. Among other benefits, this provides+  implementations of `liftTyped` on `template-haskell-2.16` (GHC 8.10) or+  later. [#1664](https://github.com/yesodweb/yesod/pull/1664)++## 1.6.17.3++* Support for `unliftio-core` 0.2++## 1.6.17.2++* Support template-haskell 2.16, build with GHC 8.10 [#1657](https://github.com/yesodweb/yesod/pull/1657)++## 1.6.17.1++* Remove unnecessary deriving of Typeable++## 1.6.17++* Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646)++## 1.6.16.1++* Compiles with GHC 8.8.1++## 1.6.16++* Add `jsAttributesHandler` to run arbitrary Handler code before building the+  attributes map for the script tag generated by `widgetFile` [#1622](https://github.com/yesodweb/yesod/pull/1622)++## 1.6.15++* Move `redirectToPost` JavaScript form submission from HTML element to+  `<script>` tag for CSP reasons [#1620](https://github.com/yesodweb/yesod/pull/1620)+ ## 1.6.14  * Introduce `JSONResponse`. [issue #1481](https://github.com/yesodweb/yesod/issues/1481) and [PR #1592](https://github.com/yesodweb/yesod/pull/1592)
bench/widget.hs view
@@ -1,15 +1,14 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}--- | BigTable benchmark implemented using Hamlet.---+{-# LANGUAGE OverloadedStrings #-}+-- BigTable benchmark implemented using Hamlet. {-# LANGUAGE QuasiQuotes #-}+ module Main where  import Gauge.Main import Text.Hamlet import qualified Data.ByteString.Lazy as L import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8-import Data.Monoid (mconcat) import Text.Blaze.Html5 (table, tr, td) import Text.Blaze.Html (toHtml) import Data.Int@@ -64,6 +63,6 @@     -}  bigTableBlaze :: Show a => [[a]] -> Int64-bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t+bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ foldMap row t   where-    row r = tr $ mconcat $ map (td . toHtml . show) r+    row r = tr $ foldMap (td . toHtml . show) r
+ docs/split-route-compilation.md view
@@ -0,0 +1,256 @@+# Split route compilation++As of yesod-core 1.7, route definitions can be split across multiple modules.+A nested route block gets its own datatype, instances, and dispatch generated+in its own module, and the main `mkYesod` splice *delegates* to that module+instead of regenerating everything in one place.++Why you'd want this:++* **Smaller TH splices.** A large site no longer needs one giant `mkYesod`+  splice that regenerates everything whenever any route changes.+* **Parallel compilation.** Each fragment module compiles independently.+* **Locality.** A route group's handlers, datatype, and dispatch live in one+  module, next to each other.+* **Faster test feedback.** Each fragment gets its own `YesodDispatchNested`+  instance, which is enough to dispatch a request on its own.+  [hspec-yesod](https://github.com/parsonsmatt/hspec-yesod) is building on+  this to run specs against a single route fragment, so a spec depends only on+  the handlers it actually exercises — editing an unrelated handler no longer+  recompiles (or relinks) the test module.++## How it works++Any nested route block — a parent declared with a trailing `:` — gets its own+route datatype:++```+/nest NestR:+    /     NestIndexR GET POST+    /#Int NestShowR  GET POST+```++By default, `mkYesod` generates the `NestR` datatype and its dispatch inline,+exactly as in 1.6. But if a `YesodDispatchNested NestR` instance is already in+scope at the splice site (because a separately compiled module generated it),+`mkYesod` delegates to that instance instead. Single-module sites are+unchanged; splitting is opt-in and per-parent.++## Recipe: top-level site++Three modules: a shared route table, the split-out fragment, and the main site.++First, put the route definitions in their own module so both sides can see+them — along with your project's `RouteOpts`. Every splice that touches the+route table should use the same options, so define them once (see+[Fallthrough](#fallthrough) for why fallthrough should be on):++```haskell+module App.Routes.Resources where++import Yesod.Core++appRouteOpts :: RouteOpts+appRouteOpts = setNestedRouteFallthrough True defaultOpts++appRouteOptsFor :: String -> RouteOpts+appRouteOptsFor name = setFocusOnNestedRoute name appRouteOpts++appResources :: [ResourceTree String]+appResources = [parseRoutes|+    /  HomeR GET++    /nest NestR:+        /     NestIndexR GET POST+        /#Int NestShowR  GET POST+|]+```++Then generate the `NestR` fragment in its own module by focusing the splice+on it. The fragment's handlers live here too:++```haskell+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module App.Routes.NestR where++import Yesod.Core+import Data.Text (Text)+import App.Routes.Resources++mkYesodOpts (appRouteOptsFor "NestR") "App" appResources++getNestIndexR :: HandlerFor App Text+getNestIndexR = pure "nest index"++postNestIndexR :: HandlerFor App Text+postNestIndexR = pure "posted"++getNestShowR :: Int -> HandlerFor App Text+getNestShowR _ = pure "nest show"++postNestShowR :: Int -> HandlerFor App Text+postNestShowR _ = pure "posted"+```++Finally, the main module imports the fragment and splices with the same+options:++```haskell+module App where++import Yesod.Core+import App.Routes.Resources+import App.Routes.NestR (NestR (..))++mkYesodOpts appRouteOpts "App" appResources++getHomeR :: HandlerFor App Text+getHomeR = pure "home"+```++Because `App.Routes.NestR` compiled first, the `mkYesodOpts` splice sees the+`YesodDispatchNested NestR` instance and delegates to it rather than+regenerating the `NestR` code. If you want to separate the datatype from the+dispatch further, `mkYesodDataOpts` and `mkYesodDispatchOpts` accept the same+options.++## Recipe: subsites++Subsites split the same way. The data module generates the subsite's route+datatype and nested-fragment instances:++```haskell+module App.SplitSub.Data where++import Yesod.Core++data SplitSub = SplitSub++mkYesodSubData "SplitSub" [parseRoutes|+/ SplitHomeR GET+/nested NestedR:+    / NestedHomeR GET+    /detail/#Int NestedDetailR GET+|]+```++The split-out module holds the nested handlers and generates the+`YesodSubDispatchNested` instance with `mkNestedSubDispatchInstance`:++```haskell+{-# OPTIONS_GHC -Wno-orphans #-}++module App.SplitSub.NestedR (NestedR (..)) where++import Yesod.Core+import Yesod.Core.Dispatch+    (mkNestedSubDispatchInstance, defaultOpts, TyArgs (..))+import App.SplitSub.Data++getNestedHomeR :: SubHandlerFor SplitSub master Text+getNestedHomeR = pure "nested home"++getNestedDetailR :: Int -> SubHandlerFor SplitSub master Text+getNestedDetailR _ = pure "nested detail"++$(mkNestedSubDispatchInstance+    defaultOpts  -- or your project-wide RouteOpts; see Fallthrough below+    "NestedR"+    []        -- no instance context+    NoTyArgs  -- no type arguments (non-parameterized subsite)+    return    -- handler unwrapper+    resourcesSplitSub)  -- the [ResourceTree String] from your routes file+```++`mkNestedSubDispatchInstance` takes the resources as `[ResourceTree String]` —+exactly what the `parseRoutes` quasi-quoter produces — and parses the type+strings internally, failing the splice with an attributable error on a+malformed type rather than a deferred runtime `error`.++And the subsite's `YesodSubDispatch` instance delegates automatically, as long+as the split-out instance is in scope:++```haskell+import App.SplitSub.Data+import App.SplitSub.NestedR ()  -- instance import only; no handlers leak++instance YesodSubDispatch SplitSub master where+    yesodSubDispatch = $(mkYesodSubDispatch resourcesSplitSub)+```++For a subsite defined entirely in one module (including parameterized subsites+like `data MySub a`), `mkYesodSubDispatchInstance "(MyClass a) => MySub a"+resourcesMySub` generates the `YesodSubDispatch` and nested instances in one+splice.++## Linking to nested routes++A nested fragment constructor isn't a `Route App` on its own — its parent may+bind dynamic pieces the fragment doesn't carry. To use a fragment in+`redirect` or `setUrl`, wrap it in `WithParentArgs` together with the parent's+dynamic arguments:++```haskell+redirect (WithParentArgs userId (ProfileEditR "name"))+```++When the parent binds no dynamic pieces, the bare constructor works directly —+generated `RedirectUrl`/`UrlToDispatch` instances fill in the empty parent+arguments:++```haskell+redirect NestIndexR+```++For this reason, if you are splitting up your routes for compilation, it is+recommended to avoid captures in the parent prefix (prefer+`/admin AdminR:` over `/user/#UserId UserR:`). With a static-only prefix,+every fragment constructor is usable directly in `redirect`/`setUrl`, and+`WithParentArgs` never enters the picture. Dynamic pieces can still live on+the individual child routes.++To convert a fragment into its parent's route type explicitly, use+`toParentRoute` from `Yesod.Core.Class.Dispatch.ToParentRoute` (not+re-exported from `Yesod.Core`, since the name is easy to collide with).++## Fallthrough++By default, once dispatch enters a nested parent whose subtree has no matching+child, the response is a 404 — later sibling routes are never tried. This+matters a lot when splitting: the usual first step is wrapping a batch of+previously-flat routes in a new nested group, and with fallthrough off, any+request matching the group's prefix now *commits* to that group. A route+declared later that shares the prefix silently becomes unreachable — flat+dispatch would have kept trying, the grouped version 404s. Enabling+`setNestedRouteFallthrough` restores the flat-dispatch behavior: a parent+whose subtree has no match falls through to the routes after it.++Fallthrough is decided per splice: each module containing a parent route+decides for its own parents. Mixing modules spliced with different options+gives confusingly inconsistent dispatch, which is why the recipe above defines+`appRouteOpts`/`appRouteOptsFor` once and uses them everywhere — don't reach+for `defaultOpts` directly in individual modules.++Related gotcha: a nested parent with *no* leading static path piece matches+unconditionally, so siblings declared after it are unreachable unless+fallthrough is enabled. Give the parent a static segment or enable+fallthrough.++## Troubleshooting++* **`Target 'NestR' was not found in resources.`** — the name passed to+  `setFocusOnNestedRoute` doesn't match any nested parent in the route table.+* **Missing-extension errors** — fragment-generating modules need+  `MultiParamTypeClasses`, and usually `FlexibleContexts` and+  `FlexibleInstances`. GHC's error names the missing extension.+* **Duplicate `RedirectUrl` instance** — the generated convenience instance is+  `OVERLAPPABLE`, so a *more specific* hand-written instance wins, but a+  hand-written instance with the identical head is still a duplicate-instance+  error.
src/Yesod/Core.hs view
@@ -1,16 +1,30 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+ module Yesod.Core     ( -- * Type classes       Yesod (..)     , YesodDispatch (..)+    , YesodDispatchNested (..)     , YesodSubDispatch (..)+    , YesodSubDispatchNested (..)     , RenderRoute (..)+    -- | Note: the 'toParentRoute' method is intentionally /not/ re-exported+    -- here. It collides with a common local binding name (e.g. the+    -- @toParentRoute@ from @getRouteToParent@), so an @import Yesod@ should not+    -- inject it. Import it from "Yesod.Core.Class.Dispatch.ToParentRoute" when+    -- you need it.+    , ToParentRoute+    , RenderRouteNested (..)     , ParseRoute (..)     , RouteAttrs (..)+    -- | @since 1.7.0.0+    , ParseRouteNested (..)+    -- | @since 1.7.0.0+    , RouteAttrsNested (..)       -- ** Breadcrumbs     , YesodBreadcrumbs (..)     , breadcrumbs@@ -18,6 +32,10 @@     , Approot (..)     , FileUpload (..)     , ErrorResponse (..)+    -- | The field accessors @theParentArgs@\/@parentArgsFor@ are not+    -- re-exported (generic names that would shadow common local bindings);+    -- only the type and its constructor are.+    , WithParentArgs (WithParentArgs)       -- * Utilities     , maybeAuthorized     , widgetToPageContent@@ -140,6 +158,7 @@ import Data.Version (showVersion) import Yesod.Routes.Class import UnliftIO (MonadIO (..), MonadUnliftIO (..))+import Yesod.Core.Class.Dispatch.ToParentRoute  import Control.Monad.Trans.Resource (MonadResource (..)) import Yesod.Core.Internal.LiteApp
src/Yesod/Core/Class/Breadcrumbs.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+ module Yesod.Core.Class.Breadcrumbs where  import Yesod.Core.Handler@@ -15,7 +17,7 @@  -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles.-breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])+breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)]) breadcrumbs = do     x <- getCurrentRoute     case x of@@ -26,6 +28,8 @@             return (title, z)   where     go back Nothing = return back-    go back (Just this) = do-        (title, next) <- breadcrumb this-        go ((this, title) : back) next+    go back (Just this)+      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this+      | otherwise = do+          (title, next) <- breadcrumb this+          go ((this, title) : back) next
src/Yesod/Core/Class/Dispatch.hs view
@@ -1,25 +1,171 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Yesod.Core.Class.Dispatch where -import qualified Network.Wai as W-import Yesod.Core.Types-import Yesod.Core.Content (ToTypedContent (..))-import Yesod.Core.Handler (sendWaiApplication)+import Data.ByteString.Builder (toLazyByteString, byteString)+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Network.HTTP.Types (status301, status307)+import Yesod.Core.Class.Dispatch.ToParentRoute import Yesod.Core.Class.Yesod+import Yesod.Core.Content (ToTypedContent (..))+import Yesod.Core.Handler (sendWaiApplication, RedirectUrl, notFound)+import Yesod.Core.Internal.Run+import Yesod.Core.Types+import Yesod.Routes.Class+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as BL+import qualified Network.Wai as W  -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Yesod site => YesodDispatch site where     yesodDispatch :: YesodRunnerEnv site -> W.Application +-- | This class enables you to dispatch on a route fragment without needing+-- to know how to dispatch on the entire route structure. This allows you+-- to break up route generation into multiple files.+--+-- For details on use, see 'setFocusOnNestedRoute'.+--+-- @since 1.7.0.0+class RenderRouteNested a => YesodDispatchNested a where+    -- | Dispatches a request to a nested route fragment.+    --+    -- The implementation uses the full WAI 'Request' to determine if the+    -- remaining path (after the parent route) matches any child routes.+    -- Returns 'Nothing' if no child routes match (for fallthrough to other+    -- routes), or 'Just' a continuation that handles the request.+    --+    -- The parent depth (number of path pieces consumed by the parent route)+    -- is statically known during Template Haskell generation and baked into+    -- the generated instance.+    --+    -- @since 1.7.0.0+    yesodDispatchNested+        :: (Yesod (ParentSite a))+        => Proxy a+        -- ^ Type proxy to resolve ambiguity from non-injective type families+        -> ParentArgs a+        -- ^ The dynamic arguments from the parent route+        -> (a -> Route (ParentSite a))+        -- ^ Function to wrap the nested route in the parent constructor+        -> YesodRunnerEnv (ParentSite a)+        -- ^ The runner environment+        -> W.Request+        -- ^ The full WAI request+        -> Maybe ((W.Response -> IO W.ResponseReceived) -> IO W.ResponseReceived)+        -- ^ Returns 'Nothing' for fallthrough, or 'Just' a continuation+        -- that completes the 'Application' type when given a respond callback++-- | 'YesodDispatchNested' is a more flexible class than 'YesodDispatch',+-- and this instance is the proof. Given a @'Route' site@ we can dispatch+-- on it as normal, so this code path works. This allows us to create+-- generalized helpers and reuse them, ensuring that nested and top-level+-- dispatch remain equivalent. This instance therefore always returns+-- @'Just'@ — committing to 'yesodDispatch', which itself terminates in+-- a 404 on a miss — rather than the 'Nothing' that the class haddock+-- describes for /fragment/ instances. The only intended caller is the+-- terminal authority 'toWaiAppYreNested', where that 404 is exactly the+-- right answer; do not rely on this instance to signal fallthrough.+instance YesodDispatch site => YesodDispatchNested (Route site) where+    yesodDispatchNested _ _ _ yre req = Just $ yesodDispatch yre req++-- | Build a WAI 'W.Application' for @site@, indexed by a @url@ type that can+-- be rendered to a route of @site@ (via 'RedirectUrl').+--+-- Note that dispatch is purely path-based: the hand-written instances below+-- discard the @url@ value (@urlToDispatch _ = yesodDispatch@) and route on the+-- request's @pathInfo@. The @url@ argument exists only to select the instance+-- and to carry the 'RedirectUrl' constraint — it is not consulted at runtime.+--+-- This is equivalent to 'YesodDispatch' but allows us to vary on the+-- @url@ type, which lets us demand additional constraints in test+-- contexts.+--+-- @since 1.7.0.0+class RedirectUrl site url => UrlToDispatch url site where+    -- | @since 1.7.0.0+    urlToDispatch :: url -> YesodRunnerEnv site -> W.Application++instance YesodDispatch site => UrlToDispatch (Route site) site where+    urlToDispatch _ = yesodDispatch++instance (YesodDispatch site, RedirectUrl site (Route site, a)) => UrlToDispatch (Route site, a) site where+    urlToDispatch _ = yesodDispatch++instance YesodDispatch site => UrlToDispatch Text site where+    urlToDispatch _ = yesodDispatch++instance YesodDispatch site => UrlToDispatch String site where+    urlToDispatch _ = yesodDispatch++-- | This instance is the pattern upon which 'UrlToDispatch' instances are+-- generated for subsite fragments. Given the constraints, we are able to+-- call 'toWaiAppYreNested' at the @route@ type with the correct arguments.+-- This allows us to create an application for a fragment of a site.+--+-- @since 1.7.0.0+instance+    ( ParentSite route ~ site+    , YesodDispatchNested route+    , RedirectUrl site (WithParentArgs route)+    , Yesod site+    , ToParentRoute route+    )+  =>+    UrlToDispatch (WithParentArgs route) site+  where+    urlToDispatch (WithParentArgs args _) =+        toWaiAppYreNested (Proxy :: Proxy route) args+ class YesodSubDispatch sub master where     yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application +-- | Like 'YesodDispatchNested', but for subsites. This class enables+-- class-based delegation for nested routes within subsites, allowing+-- module separation and symmetry with 'YesodDispatchNested'.+--+-- When a 'YesodSubDispatchNested' instance exists for a nested route type,+-- 'mkYesodSubDispatch' will delegate to it instead of inlining the dispatch.+-- Use 'mkYesodSubDispatchInstance' to generate both 'YesodSubDispatch' and+-- 'YesodSubDispatchNested' instances in one splice.+--+-- @since 1.7.0.0+class RenderRouteNested a => YesodSubDispatchNested a where+    -- | Dispatches a request for a nested route fragment within a subsite.+    --+    -- Similar to 'yesodDispatchNested', but works with 'YesodSubRunnerEnv'+    -- instead of 'YesodRunnerEnv', making it suitable for subsites.+    -- The @master@ type is universally quantified since it's not determined+    -- by the nested route type.+    --+    -- @since 1.7.0.0+    yesodSubDispatchNested+        :: Proxy a+        -- ^ Type proxy to resolve ambiguity from non-injective type families+        -> ParentArgs a+        -- ^ The dynamic arguments from the parent route+        -> (a -> Route (ParentSite a))+        -- ^ Function to wrap the nested route in the parent constructor+        -> YesodSubRunnerEnv (ParentSite a) master+        -- ^ The subsite runner environment+        -> W.Request+        -- ^ The full WAI request+        -> Maybe ((W.Response -> IO W.ResponseReceived) -> IO W.ResponseReceived)+        -- ^ Returns 'Nothing' for fallthrough, or 'Just' a continuation+ instance YesodSubDispatch WaiSubsite master where     yesodSubDispatch YesodSubRunnerEnv {..} = app       where@@ -50,3 +196,50 @@             , rheRouteToMaster = ysreToParentRoute             }        in f hd { handlerEnv = rhe' }++-- | Build a WAI 'W.Application' that dispatches starting at a nested route+-- fragment @a@ (rather than the whole @'Route' site@), given a+-- 'YesodRunnerEnv' for the parent site and the parent route's 'ParentArgs'.+-- Handles @cleanPath@ redirects and a terminal 404 just like 'toWaiAppYre'.+--+-- @since 1.7.0.0+toWaiAppYreNested+    :: (Yesod (ParentSite a), YesodDispatchNested a, ToParentRoute a)+    => Proxy a+    -> ParentArgs a+    -> YesodRunnerEnv (ParentSite a)+    -> W.Application+toWaiAppYreNested proxy parentArgs yre req =+    case cleanPath site $ W.pathInfo req of+        Left pieces -> sendRedirect site pieces req+        Right pieces -> do+            let mapplication =+                    yesodDispatchNested proxy parentArgs (toParentRoute parentArgs) yre req+                        { W.pathInfo = pieces+                        }+            case mapplication of+                Nothing ->+                    yesodRunner (notFound :: HandlerFor site ()) yre Nothing req+                Just k ->+                    k+  where+    site = yreSite yre+    sendRedirect :: Yesod master => master -> [Text] -> W.Application+    sendRedirect y segments' env sendResponse =+         sendResponse $ W.responseLBS status+                [ ("Content-Type", "text/plain")+                , ("Location", BL.toStrict $ toLazyByteString dest')+                ] "Redirecting"+      where+        -- Ensure that non-GET requests get redirected correctly. See:+        -- https://github.com/yesodweb/yesod/issues/951+        status+            | W.requestMethod env == "GET" = status301+            | otherwise                    = status307++        dest = joinPath y (resolveApproot y env) segments' []+        dest' =+            if S.null (W.rawQueryString env)+                then dest+                else dest `mappend`+                     byteString (W.rawQueryString env)
+ src/Yesod/Core/Class/Dispatch/ToParentRoute.hs view
@@ -0,0 +1,18 @@+{-# language FlexibleContexts #-}++module Yesod.Core.Class.Dispatch.ToParentRoute where++import Yesod.Routes.Class++-- | Reconstruct a full parent route from a nested route fragment and its+-- 'ParentArgs' (the dynamic pieces consumed by the ancestor parents). This is+-- what lets a fragment dispatched in its own module be rendered back into the+-- master site's @'Route' ('ParentSite' a)@.+--+-- @since 1.7.0.0+class (RenderRoute (ParentSite a)) => ToParentRoute a where+    -- | @since 1.7.0.0+    toParentRoute :: ParentArgs a -> a -> Route (ParentSite a)++instance (RenderRoute a) => ToParentRoute (Route a) where+    toParentRoute _ = id
src/Yesod/Core/Class/Handler.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+ module Yesod.Core.Class.Handler     ( MonadHandler (..)     , MonadWidget (..)@@ -19,7 +20,9 @@ import Data.Conduit.Internal (Pipe, ConduitM)  import Control.Monad.Trans.Identity ( IdentityT)+#if !MIN_VERSION_transformers(0,6,0) import Control.Monad.Trans.List     ( ListT    )+#endif import Control.Monad.Trans.Maybe    ( MaybeT   ) import Control.Monad.Trans.Except   ( ExceptT  ) import Control.Monad.Trans.Reader   ( ReaderT  )@@ -76,7 +79,9 @@ #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler GO(IdentityT)+#if !MIN_VERSION_transformers(0,6,0) GO(ListT)+#endif GO(MaybeT) GO(ExceptT e) GO(ReaderT r)@@ -104,7 +109,9 @@ #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget GO(IdentityT)+#if !MIN_VERSION_transformers(0,6,0) GO(ListT)+#endif GO(MaybeT) GO(ExceptT e) GO(ReaderT r)
src/Yesod/Core/Class/Yesod.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+ module Yesod.Core.Class.Yesod where  import           Yesod.Core.Content@@ -24,7 +25,7 @@ import           Data.List                          (foldl', nub) import qualified Data.Map                           as Map import           Data.Maybe                         (catMaybes)-import           Data.Monoid+import           Data.Monoid                        (Last (..)) import           Data.Text                          (Text) import qualified Data.Text                          as T import qualified Data.Text.Encoding                 as TE@@ -54,6 +55,7 @@ import Data.CaseInsensitive (CI) import qualified Network.Wai.Request import Data.IORef+import UnliftIO (SomeException, catch, MonadUnliftIO)  -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required.@@ -70,6 +72,16 @@     approot :: Approot site     approot = guessApproot +    -- | @since 1.6.24.0+    --  allows the user to specify how exceptions are cought.+    --  by default all async exceptions are thrown and synchronous+    --  exceptions render a 500 page.+    -- To catch all exceptions (even async) to render a 500 page,+    -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware+    -- this may have negative effects with functions like 'timeout'.+    catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a+    catchHandlerExceptions _ = catch+     -- | Output error response pages.     --     -- Default value: 'defaultErrorHandler'.@@ -87,6 +99,8 @@             <html>                 <head>                     <title>#{pageTitle p}+                    $maybe description <- pageDescription p+                      <meta name="description" content="#{description}">                     ^{pageHead p}                 <body>                     $forall (status, msg) <- msgs@@ -249,6 +263,16 @@     jsAttributes :: site -> [(Text, Text)]     jsAttributes _ = [] +    -- | Same as @jsAttributes@ but allows you to run arbitrary Handler code+    --+    -- This is useful if you need to add a randomised nonce value to the script+    -- tag generated by @widgetFile@. If this function is overridden then+    -- @jsAttributes@ is ignored.+    --+    -- @since 1.6.16+    jsAttributesHandler :: HandlerFor site [(Text, Text)]+    jsAttributesHandler = jsAttributes <$> getYesod+     -- | Create a session backend. Returning 'Nothing' disables     -- sessions. If you'd like to change the way that the session     -- cookies are created, take a look at@@ -520,15 +544,18 @@ widgetToPageContent :: Yesod site                     => WidgetFor site ()                     -> HandlerFor site (PageContent (Route site))-widgetToPageContent w = HandlerFor $ \hd -> do+widgetToPageContent w = do+ jsAttrs <- jsAttributesHandler+ HandlerFor $ \hd -> do   master <- unHandlerFor getYesod hd   ref <- newIORef mempty   unWidgetFor w WidgetData     { wdRef = ref     , wdHandler = hd     }-  GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref+  GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref   let title = maybe mempty unTitle mTitle+      description = unDescription <$> mDescription       scripts = runUniqueList scripts'       stylesheets = runUniqueList stylesheets' @@ -564,9 +591,9 @@                 ^{mkScriptTag s}             $maybe j <- jscript                 $maybe s <- jsLoc-                    <script src="#{s}" *{jsAttributes master}>+                    <script src="#{s}" *{jsAttrs}>                 $nothing-                    <script>^{jelper j}+                    <script *{jsAttrs}>^{jelper j}         |]          headAll = [hamlet|@@ -598,7 +625,7 @@             ^{regularScriptLoad}         |] -    return $ PageContent title headAll $+    return $ PageContent title description headAll $         case jsLoader master of             BottomOfBody -> bodyScript             _ -> body@@ -627,7 +654,7 @@         let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r         defaultMessageWidget "Not Found" [hamlet|<p>#{path'}|]     provideRep $ return $ object ["message" .= ("Not Found" :: Text)]-    provideRep $ return $ ("Not Found" :: Text)+    provideRep $ return ("Not Found" :: Text)  -- For API requests. -- For a user with a browser,@@ -651,7 +678,7 @@         let apair u = ["authentication_url" .= rend u]             content = maybe [] apair (authRoute site)         return $ object $ ("message" .= ("Not logged in"::Text)):content-    provideRep $ return $ ("Not logged in" :: Text)+    provideRep $ return ("Not logged in" :: Text)  defaultErrorHandler (PermissionDenied msg) = selectRep $ do     provideRep $ defaultLayout $ defaultMessageWidget@@ -670,7 +697,7 @@                     <li>#{msg}         |]     provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]-    provideRep $ return $ ("Invalid Arguments: " <> T.intercalate " " ia)+    provideRep $ return ("Invalid Arguments: " <> T.intercalate " " ia)  defaultErrorHandler (InternalError e) = do     $logErrorS "yesod-core" e
src/Yesod/Core/Content.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE OverloadedStrings #-}+ module Yesod.Core.Content     ( -- * Content       Content (..)@@ -31,6 +32,7 @@       -- * Utilities     , simpleContentType     , contentTypeTypes+    , typedContentToSnippet       -- * Evaluation strategy     , DontFullyEvaluate (..)       -- * Representations@@ -50,10 +52,12 @@  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as BB import Data.Text.Lazy (Text, pack) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8Builder) import qualified Data.Text.Lazy as TL+ import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8) import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)@@ -64,11 +68,16 @@  import qualified Data.Aeson as J import Data.Text.Lazy.Builder (toLazyText)+import Data.Void (Void, absurd) import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript)+import qualified Network.Wai.Parse as NWP+import qualified Data.Int as I import Data.Word8 (_semicolon, _slash) import Control.Arrow (second)+import Control.Exception (Exception)+import Data.Maybe  -- | Zero-length enumerator. emptyContent :: Content@@ -103,6 +112,8 @@     toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing instance ToContent () where     toContent () = toContent B.empty+instance ToContent Void where+    toContent = absurd instance ToContent (ContentType, Content) where     toContent = snd instance ToContent TypedContent where@@ -276,6 +287,8 @@     toTypedContent = id instance ToTypedContent () where     toTypedContent () = TypedContent typePlain (toContent ())+instance ToTypedContent Void where+    toTypedContent = absurd instance ToTypedContent (ContentType, Content) where     toTypedContent (ct, content) = TypedContent ct content instance ToTypedContent RepJson where
src/Yesod/Core/Dispatch.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module Yesod.Core.Dispatch     ( -- * Quasi-quoted routing       parseRoutes@@ -10,13 +14,44 @@     , parseRoutesFile     , parseRoutesFileNoCheck     , mkYesod+    , mkYesodOpts     , mkYesodWith       -- ** More fine-grained     , mkYesodData+    , mkYesodDataOpts     , mkYesodSubData+    , mkYesodSubDataOpts     , mkYesodDispatch+    , mkYesodDispatchOpts     , mkYesodSubDispatch+    , mkYesodSubDispatchInstance+    , mkYesodSubDispatchInstanceOpts+      -- *** Splitting a subsite's nested routes across modules+      --+      -- | These re-exports let a separately-compiled module generate a+      -- subsite's @YesodSubDispatchNested@ instance by hand (see the+      -- subsite-route-splitting recipe in @docs/split-route-compilation.md@).+      -- 'mkNestedSubDispatchInstance' takes the resources as+      -- @['ResourceTree' 'String']@ (the 'parseRoutes' quasi-quoter's output)+      -- and parses them internally, so no manual type-parsing is needed.++      -- | @since 1.7.0.0+    , mkNestedSubDispatchInstance+      -- | @since 1.7.0.0+    , TyArgs (..)+      -- *** Route generation options+    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setCreateResources+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , setParameterizedSubroute+    , setNestedRouteFallthrough       -- *** Helpers+    , defaultGen     , getGetMaxExpires       -- ** Path pieces     , PathPiece (..)@@ -25,12 +60,18 @@       -- * Convert to WAI     , toWaiApp     , toWaiAppPlain+    , UrlToDispatch(..)+    , mkYesodRunnerEnv+    , toWaiAppPlainNested     , toWaiAppYre+    , toWaiAppYreNested     , warp     , warpDebug     , warpEnv     , mkDefaultMiddlewares     , defaultMiddlewaresNoLogging+      -- * Subsite nested dispatch+    , YesodSubDispatchNested (..)       -- * WAI subsites     , WaiSubsite (..)     , WaiSubsiteWithAuth (..)@@ -39,6 +80,8 @@ import Prelude hiding (exp) import Yesod.Core.Internal.TH import Language.Haskell.TH.Syntax (qLocation)+import Data.Proxy+import Yesod.Routes.Class  import Web.PathPieces @@ -46,27 +89,34 @@  import Data.ByteString.Lazy.Char8 () +import Data.Bits ((.|.), finiteBitSize, shiftL) import Data.Text (Text) import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as S8-import Data.ByteString.Builder (byteString, toLazyByteString)-import Network.HTTP.Types (status301, status307)+#if !MIN_VERSION_wai_extra(3,1,14)+import Data.Default (def)+#endif import Yesod.Routes.Parse+import Yesod.Routes.TH (TyArgs (..)) import Yesod.Core.Types import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch-import Yesod.Core.Internal.Run import Text.Read (readMaybe) import System.Environment (getEnvironment)-import qualified System.Random as Random+import System.Entropy (getEntropy) import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)+import Yesod.Core.Class.Dispatch.ToParentRoute  import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.RequestLogger-import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.Gzip (+    gzip,+#if MIN_VERSION_wai_extra(3,1,14)+    defaultGzipSettings,+#endif+ ) import Network.Wai.Middleware.MethodOverride  import qualified Network.Wai.Handler.Warp@@ -81,19 +131,67 @@ -- used middlewares, please use 'toWaiApp'. toWaiAppPlain :: YesodDispatch site => site -> IO W.Application toWaiAppPlain site = do+    yre <- mkYesodRunnerEnv site+    return $ toWaiAppYre yre++-- | Construct a 'YesodRunnerEnv' for a site, initializing its logger, session+-- backend, and other runtime state. This is the environment threaded through+-- dispatch; 'toWaiAppPlain' and friends build one for you, but it is exposed so+-- callers can construct and reuse a runner environment directly.+--+-- @since 1.7.0.0+mkYesodRunnerEnv :: Yesod site => site -> IO (YesodRunnerEnv site)+mkYesodRunnerEnv site = do     logger <- makeLogger site     sb <- makeSessionBackend site     getMaxExpires <- getGetMaxExpires-    return $ toWaiAppYre YesodRunnerEnv-            { yreLogger = logger-            , yreSite = site-            , yreSessionBackend = sb-            , yreGen = defaultGen-            , yreGetMaxExpires = getMaxExpires-            }+    pure YesodRunnerEnv+        { yreLogger = logger+        , yreSite = site+        , yreSessionBackend = sb+        , yreGen = defaultGen+        , yreGetMaxExpires = getMaxExpires+        } +-- | Convert the given argument into a WAI application, executable with any WAI+-- handler. This function will provide no middlewares; if you want commonly+-- used middlewares, please use 'toWaiApp'.+--+-- This function allows you to create an 'Application' that only responds+-- to a subset of the 'site' routes. This is really only useful for writing+-- tests, but it does allow you to write tests that only depend on a subset+-- of the handlers instead of all handlers.+--+-- @since 1.7.0.0+toWaiAppPlainNested+    :: ( site ~ ParentSite route+        , Yesod site+        , YesodDispatchNested route+        , ToParentRoute route+        )+    => Proxy route+    -> ParentArgs route+    -> site+    -> IO W.Application+toWaiAppPlainNested proxy parentArgs site = do+    yre <- mkYesodRunnerEnv site+    return $ toWaiAppYreNested proxy parentArgs yre++-- | Generate a random number uniformly distributed in the full range+-- of 'Int'.+--+-- Note: Before 1.6.20, this generates pseudo-random number in an+-- unspecified range. The range size may not be a power of 2. Since+-- 1.6.20, this uses a secure entropy source and generates in the full+-- range of 'Int'.+--+-- @since 1.6.21.0 defaultGen :: IO Int-defaultGen = Random.getStdRandom Random.next+defaultGen = bsToInt <$> getEntropy bytes+  where+    bits = finiteBitSize (undefined :: Int)+    bytes = div (bits + 7) 8+    bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0  -- | Pure low level function to construct WAI application. Usefull -- when you need not standard way to run your app, or want to embed it@@ -101,33 +199,7 @@ -- -- @since 1.4.29 toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application-toWaiAppYre yre req =-    case cleanPath site $ W.pathInfo req of-        Left pieces -> sendRedirect site pieces req-        Right pieces -> yesodDispatch yre req-            { W.pathInfo = pieces-            }-  where-    site = yreSite yre-    sendRedirect :: Yesod master => master -> [Text] -> W.Application-    sendRedirect y segments' env sendResponse =-         sendResponse $ W.responseLBS status-                [ ("Content-Type", "text/plain")-                , ("Location", BL.toStrict $ toLazyByteString dest')-                ] "Redirecting"-      where-        -- Ensure that non-GET requests get redirected correctly. See:-        -- https://github.com/yesodweb/yesod/issues/951-        status-            | W.requestMethod env == "GET" = status301-            | otherwise                    = status307--        dest = joinPath y (resolveApproot y env) segments' []-        dest' =-            if S.null (W.rawQueryString env)-                then dest-                else dest `mappend`-                     byteString (W.rawQueryString env)+toWaiAppYre = toWaiAppYreNested (Proxy :: Proxy (Route site)) ()  -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This -- set may change with future releases, but currently covers:@@ -172,6 +244,16 @@ -- middlewares. This set may change at any point without a breaking version -- number. Currently, it includes: --+-- * Logging+--+-- * GZIP compression+--+-- * Automatic HEAD method handling+--+-- * Request method override with the _method query string parameter+--+-- * Accept header override with the _accept query string parameter+-- -- If you need more fine-grained control of middlewares, please use 'toWaiApp' -- directly. --@@ -209,7 +291,12 @@ -- Since 1.2.0 mkDefaultMiddlewares :: Logger -> IO W.Middleware mkDefaultMiddlewares logger = do-    logWare <- mkRequestLogger def+    logWare <- mkRequestLogger+#if MIN_VERSION_wai_extra(3,1,8)+        defaultRequestLoggerSettings+#else+        def+#endif         { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger         , outputFormat = Apache FromSocket         }@@ -219,7 +306,14 @@ -- -- Since 1.2.12 defaultMiddlewaresNoLogging :: W.Middleware-defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride+defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip gzipSettings . methodOverride+  where+    gzipSettings =+#if MIN_VERSION_wai_extra(3,1,14)+        defaultGzipSettings+#else+        def+#endif  -- | Deprecated synonym for 'warp'. warpDebug :: YesodDispatch site => Int -> site -> IO ()
src/Yesod/Core/Handler.hs view
@@ -1,15 +1,19 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FunctionalDependencies     #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE QuasiQuotes                #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE TupleSections              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ --------------------------------------------------------- -- -- Module        : Yesod.Handler@@ -91,7 +95,8 @@     , permissionDeniedI     , invalidArgs     , invalidArgsI-      -- ** Short-circuit responses.+      -- ** Short-circuit responses+      -- $rollbackWarning     , sendFile     , sendFilePart     , sendResponse@@ -244,10 +249,10 @@ import qualified Data.IORef                    as I import           Data.Maybe                    (listToMaybe, mapMaybe) import           Data.Typeable                 (Typeable)+import           Data.Kind                     (Type) import           Web.PathPieces                (PathPiece(..)) import           Yesod.Core.Class.Handler import           Yesod.Core.Types-import           Yesod.Routes.Class            (Route) import           Data.ByteString.Builder (Builder) import           Data.CaseInsensitive (CI, original) import qualified Data.Conduit.List as CL@@ -259,8 +264,10 @@ import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold import           Control.Monad.Logger (MonadLogger, logWarnS)+import Yesod.Routes.Class (WithParentArgs(..), ParentSite(..))+import Yesod.Core.Class.Dispatch.ToParentRoute (ToParentRoute(..)) -type HandlerT site (m :: * -> *) = HandlerFor site+type HandlerT site (m :: Type -> Type) = HandlerFor site {-# DEPRECATED HandlerT "Use HandlerFor directly" #-}  get :: MonadHandler m => m GHState@@ -369,10 +376,10 @@ getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m))) getCurrentRoute = rheRoute <$> askHandlerEnv --- | Returns a function that runs 'HandlerT' actions inside @IO@.+-- | Returns a function that runs 'HandlerFor' actions inside @IO@. ----- Sometimes you want to run an inner 'HandlerT' action outside--- the control flow of an HTTP request (on the outer 'HandlerT'+-- Sometimes you want to run an inner 'HandlerFor' action outside+-- the control flow of an HTTP request (on the outer 'HandlerFor' -- action).  For example, you may want to spawn a new thread: -- -- @@@ -380,30 +387,30 @@ -- getFooR = do --   runInnerHandler <- handlerToIO --   liftIO $ forkIO $ runInnerHandler $ do---     /Code here runs inside GHandler but on a new thread./---     /This is the inner GHandler./+--     /Code here runs inside HandlerFor but on a new thread./+--     /This is the inner HandlerFor./ --     ... --   /Code here runs inside the request's control flow./---   /This is the outer GHandler./+--   /This is the outer HandlerFor./ --   ... -- @ -- -- Another use case for this function is creating a stream of--- server-sent events using 'GHandler' actions (see+-- server-sent events using 'HandlerFor' actions (see -- @yesod-eventsource@). ----- Most of the environment from the outer 'GHandler' is preserved--- on the inner 'GHandler', however:+-- Most of the environment from the outer 'HandlerFor' is preserved+-- on the inner 'HandlerFor', however: -- --  * The request body is cleared (otherwise it would be very --  difficult to prevent huge memory leaks). -----  * The cache is cleared (see 'CacheKey').+--  * The cache is cleared (see 'cached'). ----- Changes to the response made inside the inner 'GHandler' are+-- Changes to the response made inside the inner 'HandlerFor' are -- ignored (e.g., session variables, cookies, response headers).--- This allows the inner 'GHandler' to outlive the outer--- 'GHandler' (e.g., on the @forkIO@ example above, a response+-- This allows the inner 'HandlerFor' to outlive the outer+-- 'HandlerFor' (e.g., on the @forkIO@ example above, a response -- may be sent to the client without killing the new thread). handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a) handlerToIO =@@ -413,9 +420,15 @@           where             oldReq    = handlerRequest oldHandlerData             oldWaiReq = reqWaiRequest oldReq+#if MIN_VERSION_wai(3,2,4)+            newWaiReq =+                W.setRequestBodyChunks (return mempty) $+                    oldWaiReq { W.requestBodyLength = W.KnownLength 0 }+#else             newWaiReq = oldWaiReq { W.requestBody = return mempty                                   , W.requestBodyLength = W.KnownLength 0                                   }+#endif         oldEnv = handlerEnv oldHandlerData     newState <- liftIO $ do       oldState <- I.readIORef (handlerState oldHandlerData)@@ -428,7 +441,7 @@     -- xx From this point onwards, no references to oldHandlerData xx     liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ()) -    -- Return GHandler running function.+    -- Return HandlerFor running function.     return $ \(HandlerFor f) ->       liftIO $       runResourceT $ withInternalState $ \resState -> do@@ -607,6 +620,20 @@ getMessage :: MonadHandler m => m (Maybe Html) getMessage = fmap (fmap snd . listToMaybe) getMessages +-- $rollbackWarning+--+-- Note that since short-circuiting is implemented by using exceptions,+-- using e.g. 'sendStatusJSON' inside a runDB block+-- will result in the database actions getting rolled back:+--+-- @+-- runDB $ do+--   userId <- insert $ User "username" "email@example.com"+--   postId <- insert $ BlogPost "title" "hi there!"+--     /The previous two inserts will be rolled back./+--   sendStatusJSON Status.status200 ()+-- @+ -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to@@ -1008,6 +1035,17 @@         r <- getUrlRender         return $ r url +instance+    ( RedirectUrl master (Route master)+    , ParentSite url ~ master+    , ToParentRoute url+    )+  =>+    RedirectUrl master (WithParentArgs url)+  where+    toTextUrl (WithParentArgs args url) =+        toTextUrl (toParentRoute args url)+ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where     toTextUrl (url, params) = do         r <- getUrlRenderParams@@ -1022,7 +1060,7 @@ -- > redirect (NewsfeedR :#: storyId) -- -- @since 1.2.9.-data Fragment a b = a :#: b deriving (Show, Typeable)+data Fragment a b = a :#: b deriving Show  instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where   toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a@@ -1069,13 +1107,15 @@ <html>     <head>         <title>Redirecting...-    <body onload="document.getElementById('form').submit()">+    <body>         <form id="form" method="post" action=#{urlText}>             $maybe token <- reqToken req                 <input type=hidden name=#{defaultCsrfParamName} value=#{token}>             <noscript>                 <p>Javascript has been disabled; please click on the button below to be redirected.             <input type="submit" value="Continue">+        <script>+          window.onload = function() { document.getElementById('form').submit(); }; |] >>= sendResponse  -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.@@ -1209,10 +1249,10 @@ -- Languages are determined based on the following (in descending order -- of preference): ----- * The _LANG user session variable.--- -- * The _LANG get parameter. --+-- * The _LANG user session variable.+-- -- * The _LANG cookie. -- -- * Accept-Language HTTP header.@@ -1221,11 +1261,12 @@ -- If a matching language is not found the default language will be used. -- -- This is handled by parseWaiRequest (not exposed).+--+-- __NOTE__: Before version @1.6.19.0@, this function prioritized the session+-- variable above all other sources.+-- languages :: MonadHandler m => m [Text]-languages = do-    mlang <- lookupSession langKey-    langs <- reqLangs <$> getRequest-    return $ maybe id (:) mlang langs+languages = reqLangs <$> getRequest  lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x)@@ -1415,7 +1456,11 @@ rawRequestBody = do     req <- lift waiRequest     let loop = do+#if MIN_VERSION_wai(3,2,2)+            bs <- liftIO $ W.getRequestBodyChunk req+#else             bs <- liftIO $ W.requestBody req+#endif             unless (S.null bs) $ do                 yield bs                 loop@@ -1447,8 +1492,8 @@  -- | Use a @Source@ for the response body. ----- Note that, for ease of use, the underlying monad is a @HandlerT@. This--- implies that you can run any @HandlerT@ action. However, since a streaming+-- Note that, for ease of use, the underlying monad is a @HandlerFor@. This+-- implies that you can run any @HandlerFor@ action. However, since a streaming -- response occurs after the response headers have already been sent, some -- actions make no sense here. For example: short-circuit responses, setting -- headers, changing status codes, etc.@@ -1459,8 +1504,8 @@               -> HandlerFor site TypedContent respondSource ctype src = HandlerFor $ \hd ->     -- Note that this implementation relies on the fact that the ResourceT-    -- environment provided by the server is the same one used in HandlerT.-    -- This is a safe assumption assuming the HandlerT is run correctly.+    -- environment provided by the server is the same one used in HandlerFor.+    -- This is a safe assumption assuming the HandlerFor is run correctly.     return $ TypedContent ctype $ ContentSource            $ transPipe (lift . flip unHandlerFor hd) src
src/Yesod/Core/Internal/LiteApp.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE TypeFamilies, PatternGuards, CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}+ module Yesod.Core.Internal.LiteApp where -#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup(..))-#endif import Yesod.Routes.Class import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch@@ -47,9 +46,6 @@  instance Monoid LiteApp where     mempty = LiteApp $ \_ _ -> Nothing-#if !(MIN_VERSION_base(4,11,0))-    mappend = (<>)-#endif  type LiteHandler = HandlerFor LiteApp type LiteWidget = WidgetFor LiteApp
src/Yesod/Core/Internal/Request.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+ module Yesod.Core.Internal.Request     ( parseWaiRequest     , RequestBodyContents@@ -49,9 +51,12 @@ limitRequestBody :: Word64 -> W.Request -> IO W.Request limitRequestBody maxLen req = do     ref <- newIORef maxLen-    return req-        { W.requestBody = do+    let bd = do+#if MIN_VERSION_wai(3,2,2)+            bs <- W.getRequestBodyChunk req+#else             bs <- W.requestBody req+#endif             remaining <- readIORef ref             let len = fromIntegral $ S8.length bs                 remaining' = remaining - len@@ -60,13 +65,17 @@                 else do                     writeIORef ref remaining'                     return bs-        }+#if MIN_VERSION_wai(3,2,4)+    return $ W.setRequestBodyChunks bd req+#else+    return req { W.requestBody = bd }+#endif  tooLargeResponse :: Word64 -> Word64 -> W.Response tooLargeResponse maxLen bodyLen = W.responseLBS     (Status 413 "Too Large")     [("Content-Type", "text/plain")]-    (L.concat +    (L.concat         [ "Request body too large to be processed. The maximum size is "         , (LS8.pack (show maxLen))         , " bytes; your request body was "@@ -129,7 +138,7 @@                 -- Already have a token, use it.                 Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs                 -- Don't have a token, get a random generator and make a new one.-                Nothing -> Right $ fmap Just . randomString 10+                Nothing -> Right $ fmap Just . randomString 40         | otherwise = Left Nothing  textQueryString :: W.Request -> [(Text, Text)]
src/Yesod/Core/Internal/Response.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}+ module Yesod.Core.Internal.Response where  import           Data.ByteString              (ByteString)
src/Yesod/Core/Internal/Run.hs view
@@ -1,14 +1,29 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards     #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE FlexibleContexts  #-}-module Yesod.Core.Internal.Run where+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} +module Yesod.Core.Internal.Run+  ( toErrorHandler+  , errFromShow+  , basicRunHandler+  , handleError+  , handleContents+  , evalFallback+  , runHandler+  , safeEh+  , runFakeHandler+  , yesodRunner+  , yesodRender+  , resolveApproot+  )+  where -import Yesod.Core.Internal.Response+import           Yesod.Core.Internal.Response import           Data.ByteString.Builder      (toLazyByteString) import qualified Data.ByteString.Lazy         as BL import           Control.Monad.IO.Class       (MonadIO, liftIO)@@ -28,7 +43,6 @@ import           Language.Haskell.TH.Syntax   (Loc, qLocation) import qualified Network.HTTP.Types           as H import           Network.Wai-import           Network.Wai.Internal import           System.Log.FastLogger        (LogStr, toLogStr) import           Yesod.Core.Content import           Yesod.Core.Class.Yesod@@ -36,7 +50,7 @@ import           Yesod.Core.Internal.Request  (parseWaiRequest,                                                tooLargeResponse) import           Yesod.Core.Internal.Util     (getCurrentMaxExpiresRFC1123)-import           Yesod.Routes.Class           (Route, renderRoute)+import           Yesod.Routes.Class           (RenderRoute (..)) import           Control.DeepSeq              (($!!), NFData) import           UnliftIO.Exception @@ -71,7 +85,7 @@      -- Run the handler itself, capturing any runtime exceptions and     -- converting them into a @HandlerContents@-    contents' <- catchAny+    contents' <- rheCatchHandlerExceptions rhe         (do             res <- unHandlerFor handler (hd istate)             tc <- evaluate (toTypedContent res)@@ -172,16 +186,19 @@ -- | Evaluate the given value. If an exception is thrown, use it to -- replace the provided contents and then return @mempty@ in place of the -- evaluated value.+--+-- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w)-             => HandlerContents+             => (forall a. IO a -> (SomeException -> IO a) -> IO a)+             -> HandlerContents              -> w              -> IO (w, HandlerContents)-evalFallback contents val = catchAny+evalFallback catcher contents val = catcher     (fmap (, contents) (evaluate $!! val))     (fmap ((mempty, ) . HCError) . toErrorHandler)  -- | Function used internally by Yesod in the process of converting a--- 'HandlerT' into an 'Application'. Should not be needed by users.+-- 'HandlerFor' into an 'Application'. Should not be needed by users. runHandler :: ToTypedContent c            => RunHandlerEnv site site            -> HandlerFor site c@@ -192,8 +209,8 @@      -- Evaluate the unfortunately-lazy session and headers,     -- propagating exceptions into the contents-    (finalSession, contents1) <- evalFallback contents0 (ghsSession state)-    (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])+    (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state)+    (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) [])     contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)      -- Convert the HandlerContents into the final YesodResponse@@ -216,27 +233,27 @@         (toContent ("Internal Server Error" :: S.ByteString))         (reqSession req) --- | Run a 'HandlerT' completely outside of Yesod.  This+-- | Run a 'HandlerFor' completely outside of Yesod.  This -- function comes with many caveats and you shouldn't use it -- unless you fully understand what it's doing and how it works. -- -- As of now, there's only one reason to use this function at--- all: in order to run unit tests of functions inside 'HandlerT'+-- all: in order to run unit tests of functions inside 'HandlerFor' -- but that aren't easily testable with a full HTTP request. -- Even so, it's better to use @wai-test@ or @yesod-test@ instead -- of using this function. -- -- This function will create a fake HTTP request (both @wai@'s -- 'Request' and @yesod@'s 'Request') and feed it to the--- @HandlerT@.  The only useful information the @HandlerT@ may+-- @HandlerFor@.  The only useful information the @HandlerFor@ may -- get from the request is the session map, which you must supply -- as argument to @runFakeHandler@.  All other fields contain -- fake information, which means that they can be accessed but -- won't have any useful information.  The response of the--- @HandlerT@ is completely ignored, including changes to the+-- @HandlerFor@ is completely ignored, including changes to the -- session, cookies or headers.  We only return you the--- @HandlerT@'s return value.-runFakeHandler :: (Yesod site, MonadIO m) =>+-- @HandlerFor@'s return value.+runFakeHandler :: forall site m a . (Yesod site, MonadIO m) =>                   SessionMap                -> (site -> Logger)                -> site@@ -257,6 +274,7 @@             , rheLog = messageLoggerSource site $ logger site             , rheOnError = errHandler             , rheMaxExpires = maxExpires+            , rheCatchHandlerExceptions = catchHandlerExceptions site             }         handler'       errHandler err req = do@@ -267,23 +285,12 @@                      typePlain                      (toContent ("runFakeHandler: errHandler" :: S8.ByteString))                      (reqSession req)-      fakeWaiRequest = Request+      fakeWaiRequest = defaultRequest           { requestMethod  = "POST"           , httpVersion    = H.http11           , rawPathInfo    = "/runFakeHandler/pathInfo"-          , rawQueryString = ""-          , requestHeaderHost = Nothing-          , requestHeaders = []-          , isSecure       = False           , remoteHost     = error "runFakeHandler-remoteHost"           , pathInfo       = ["runFakeHandler", "pathInfo"]-          , queryString    = []-          , requestBody    = return mempty-          , vault          = mempty-          , requestBodyLength = KnownLength 0-          , requestHeaderRange = Nothing-          , requestHeaderReferer = Nothing-          , requestHeaderUserAgent = Nothing           }       fakeRequest =         YesodRequest@@ -298,7 +305,7 @@   _ <- runResourceT $ yapp fakeRequest   I.readIORef ret -yesodRunner :: (ToTypedContent res, Yesod site)+yesodRunner :: forall res site . (ToTypedContent res, Yesod site)             => HandlerFor site res             -> YesodRunnerEnv site             -> Maybe (Route site)@@ -333,6 +340,7 @@               , rheLog = log'               , rheOnError = safeEh log'               , rheMaxExpires = maxExpires+              , rheCatchHandlerExceptions = catchHandlerExceptions yreSite               }           rhe = rheSafe               { rheOnError = runHandler rheSafe . errorHandler@@ -343,7 +351,6 @@           yar <- runInternalState (runHandler rhe handler yreq') is           yarToResponse yar saveSession yreq' req is sendResponse   where-    mmaxLen = maximumContentLength yreSite route     handler = yesodMiddleware handler'  yesodRender :: Yesod y
src/Yesod/Core/Internal/TH.hs view
@@ -1,45 +1,98 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Core.Internal.TH where+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} +module Yesod.Core.Internal.TH+    ( mkYesod+    , mkYesodOpts++    , mkYesodWith++    , mkYesodData+    , mkYesodDataOpts++    , mkYesodSubData+    , mkYesodSubDataOpts++    , mkYesodWithParser+    , mkYesodWithParserOpts++    , mkYesodDispatch+    , mkYesodDispatchOpts++    , masterTypeSyns++    , mkYesodGeneral+    , mkYesodGeneralOpts++    , mkMDS+    , mkDispatchInstance++    , mkYesodSubDispatch+    , mkYesodSubDispatchInstance+    , mkYesodSubDispatchInstanceOpts+    , mkNestedSubDispatchInstance++    , subTopDispatch++    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setCreateResources+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , setParameterizedSubroute+    , setNestedRouteFallthrough+    )+ where+ import Prelude hiding (exp) import Yesod.Core.Handler- import Language.Haskell.TH hiding (cxt, instanceD) import Language.Haskell.TH.Syntax--import qualified Network.Wai as W- import Data.ByteString.Lazy.Char8 () import Data.List (foldl')-import Control.Monad (replicateM, void)-import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)-import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)-+import Data.Maybe+import Control.Monad import Yesod.Routes.TH+import Yesod.Routes.TH.Dispatch+    (parseYesodName, mkYesodSubDispatchWithDelegate, SameSpliceNestedInstances (..))+import Yesod.Routes.TH.Internal (instanceD, typeArity, assertNestedSubArity, ArityCallSite(..), SubsiteName(..), SubsiteArity(..), resolveRouteCon, nestedInstanceExists) import Yesod.Routes.Parse import Yesod.Core.Types-import Yesod.Core.Class.Dispatch-import Yesod.Core.Internal.Run+import Yesod.Core.Class.Dispatch (YesodSubDispatch(..), YesodSubDispatchNested(..))  -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter. -- Use 'parseRoutes' to create the 'Resource's. ----- Contexts and type variables in the name of the datatype are parsed. +-- Contexts and type variables in the name of the datatype are parsed. -- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@. 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. --- Instead, they are explicitly provided. +-- | Similar to 'mkYesod', except contexts and type variables are not parsed.+-- Instead, they are explicitly provided. -- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@. mkYesodWith :: [[String]] -- ^ list of contexts             -> String -- ^ name of the argument datatype@@ -48,71 +101,95 @@             -> 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+++-- | Run 'parseYesodName' in 'Q', failing the splice with the parse error+-- instead of returning an 'Either'. Shared by the @mkYesod@ and+-- @mkYesodSubDispatch@ entry points.+parseYesodNameQ :: String -> Q (String, [String], [[String]])+parseYesodNameQ name =+    case parseYesodName name of+        Left err -> fail err+        Right a  -> pure a+ -- | 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-    let (name', rest, cxt) = case parse parseName "" name of-            Left err -> error $ show err-            Right a -> a-    mkYesodGeneral cxt name' rest isSub f resS+mkYesodWithParser = mkYesodWithParserOpts defaultOpts -    where-        parseName = do-            cxt <- option [] parseContext-            name' <- parseWord-            args <- many parseWord-            spaces-            eof-            return ( name', args, cxt)+-- | 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+    (name', rest, cxt) <- parseYesodNameQ name -        parseWord = do-            spaces-            many1 alphaNum+    mkYesodGeneralOpts opts cxt name' rest isSub f resS -        parseContext = try $ do-            cxts <- parseParen parseContexts-            spaces-            _ <- string "=>"-            return cxts -        parseParen p = do-            spaces-            _ <- char '('-            r <- p-            spaces-            _ <- char ')'-            return r--        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+++-- | Build an instance context ('Cxt') from the parsed @=>@ class-application+-- groups produced by 'parseYesodName'. Each group is a class name applied to+-- type arguments, e.g. @["MyClass","a"]@ becomes @MyClass a@. Shared by+-- 'mkYesodGeneralOpts' and 'mkYesodSubDispatchInstanceOpts'.+buildAppCxt :: [[String]] -> Q Cxt+buildAppCxt = traverse $ \ctxs ->+    case ctxs of+        c:rest ->+            pure $ foldl' (\acc v -> acc `AppT` fst (nameToType v)) (ConT $ mkName c) rest+        [] -> fail $ "mkYesod: empty type-class context in route definition: " ++ show ctxs+ -- | 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 =-    [ TySynD (mkName "Handler") (fmap PlainTV vs)+    [ TySynD (mkName "Handler") (fmap plainTV vs)       $ ConT ''HandlerFor `AppT` site-    , TySynD (mkName "Widget")  (fmap PlainTV vs)+    , TySynD (mkName "Widget")  (fmap plainTV vs)       $ 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@@ -120,101 +197,294 @@                -> (Exp -> Q Exp)            -- ^ unwrap handler                -> [ResourceTree String]                -> Q([Dec],[Dec])-mkYesodGeneral appCxt' namestr mtys isSub f resS = do-    let appCxt = fmap (\(c:rest) -> -            foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest-          ) appCxt'+mkYesodGeneral = mkYesodGeneralOpts defaultOpts++-- | Convert the parsed-from-source 'String' route types into real 'Type's at a+-- splice site. A malformed type or an unclosed @#{…}@ bracket surfaces as an+-- attributed compile error (via 'fail') rather than a raw 'error' thrown lazily+-- when the resulting tree is forced. This is the single 'String'-to-'Type'+-- boundary: callers downstream only ever handle @['ResourceTree' 'Type']@.+parseResourceTypes :: [ResourceTree String] -> Q [ResourceTree Type]+parseResourceTypes = traverse (traverse (\s -> dropBracketM s >>= parseTypeM))++-- | Generate a @YesodSubDispatchNested@ instance for a nested route within a+-- subsite, for hand-written split-route modules (see the subsite-splitting+-- recipe in @docs/split-route-compilation.md@).+--+-- Takes the resources as @['ResourceTree' 'String']@ — exactly the form the+-- @parseRoutes@ quasi-quoter produces — and parses them to 'Type' internally+-- via 'parseResourceTypes', so the caller never touches the partial+-- 'parseType'\/'dropBracket'. A malformed type fails the splice with an+-- attributed error instead.+--+-- @since 1.7.0.0+mkNestedSubDispatchInstance+    :: RouteOpts+    -> String                -- ^ target nested route name+    -> Cxt                   -- ^ instance context+    -> TyArgs                -- ^ type arguments+    -> (Exp -> Q Exp)        -- ^ unwrapper+    -> [ResourceTree String] -- ^ all resources (as parsed from source)+    -> Q [Dec]+mkNestedSubDispatchInstance routeOpts target cxt tyargs unwrapper resS = do+    res <- parseResourceTypes resS+    -- Guard the top target's arity here. 'mkNestedDispatchInstanceWith' only+    -- arity-checks nested *children*, so without this a hand-written recipe+    -- pairing a parameterized subsite with an unparameterized target datatype+    -- would apply the subsite's type args to a kind-'Type' head and surface a+    -- cryptic kind error from generated code rather than this actionable one.+    -- A no-op when the datatype is not in scope (unknowable arity) or when the+    -- arities match.+    rc <- resolveRouteCon target+    assertNestedSubArity SubsiteCall (SubsiteName target)+        (SubsiteArity (tyArgsArity tyargs)) rc+    mkNestedDispatchInstanceWith SubsiteNested Nothing+        routeOpts target cxt tyargs unwrapper res++-- | The resolved foundation type shared by 'mkYesodGeneralOpts' and+-- 'mkYesodSubDispatchInstanceOpts': the @boundNames@ from the explicitly-written+-- type args plus enough fresh @t@ variables to fill the reified arity, the fully+-- applied @site@ type, and the parsed resources. The callers differ only in how+-- they roll these into 'TyArgs' (and the synonym-head vars), so that part stays+-- with each caller.+data ResolvedFoundation = ResolvedFoundation+    { rfBoundNames :: [(Type, Name)]  -- ^ explicitly-written type args+    , rfFillVars   :: [Name]          -- ^ fresh vars filling the reified arity+    , rfSite       :: Type            -- ^ the fully applied site type+    , rfResources  :: [ResourceTree Type]+    }++resolveFoundation :: String -> [String] -> [ResourceTree String] -> Q ResolvedFoundation+resolveFoundation namestr mtys resS = do     mname <- lookupTypeName namestr-    arity <- case mname of-               Just name -> do-                 info <- reify name-                 return $-                   case info of-                     TyConI dec ->-                       case dec of-                         DataD _ _ vs _ _ _ -> length vs-                         NewtypeD _ _ vs _ _ _ -> length vs-                         TySynD _ vs _ -> length vs-                         _ -> 0-                     _ -> 0-               _ -> return 0+    arity <- maybe (pure 0) typeArity mname     let name = mkName namestr     -- Generate as many variable names as the arity indicates     vns <- replicateM (arity - length mtys) $ newName "t"-        -- Base type (site type with variables)-    let argtypes = fmap nameToType mtys ++ fmap VarT vns+    let boundNames = fmap nameToType mtys+        argtypes = fmap fst boundNames ++ fmap VarT vns         site = foldl' AppT (ConT name) argtypes-        res = map (fmap (parseType . dropBracket)) resS-    renderRouteDec <- mkRenderRouteInstance appCxt site res-    routeAttrsDec  <- mkRouteAttrsInstance appCxt site res-    dispatchDec    <- mkDispatchInstance site appCxt f res-    parseRoute <- mkParseRouteInstance appCxt site res+    res <- parseResourceTypes resS+    pure ResolvedFoundation+        { rfBoundNames = boundNames+        , rfFillVars = vns+        , rfSite = site+        , rfResources = res+        }++-- |+--+-- @since 1.6.25.0+mkYesodGeneralOpts :: RouteOpts                 -- ^ Options to adjust route creation+                   -> [[String]]                -- ^ Application 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+    appCxt <- buildAppCxt appCxt'+    foundation <- resolveFoundation namestr mtys resS+    -- The explicitly-written args plus the fresh vars filling the reified+    -- arity. Both are part of the site's full application ('rfSite'), so both+    -- must travel in the 'TyArgs' handed to 'discoveryMode' and the generators+    -- — otherwise a parameterized foundation invoked without explicit type args+    -- would be misclassified as monomorphic and emit ill-scoped nested+    -- instances.+    let fillNames = fmap (\v -> (VarT v, v)) (rfFillVars foundation)+        tyArgs = toTyArgs (rfBoundNames foundation ++ fillNames)+    -- typevars that should appear in synonym head+    let argvars = (fmap mkName . filter isTvar) mtys ++ rfFillVars foundation+    renderRouteDec <-+        mkRenderRouteInstanceOpts opts appCxt tyArgs (rfSite foundation) (rfResources foundation)+    routeAttrsDec  <-+        case roFocusOnNestedRoute opts of+            Nothing -> do+                -- The flat 'RouteAttrs (Route site)' instance, plus — in+                -- nested-discovery mode — a 'RouteAttrsNested' instance for each+                -- child fragment, mirroring the RenderRouteNested /+                -- ParseRouteNested / YesodDispatchNested instances generated for+                -- the same children. Without this, 'routeAttrsNested ChildR'+                -- would fail to resolve for a single-module 'mkYesod' site even+                -- though the other nested-delegation methods resolve.+                flatAttrs <- mkRouteAttrsInstance appCxt (rfSite foundation) (rfResources foundation)+                nestedAttrs <-+                    case discoveryMode opts tyArgs of+                        NestedDiscovery ->+                            mkRouteAttrsNestedInstances appCxt tyArgs (rfResources foundation)+                        InlineCompat    -> pure []+                pure (flatAttrs : nestedAttrs)+            Just target ->+                -- Apply the site's type arguments to the focused child's+                -- constructor, matching the focused ParseRoute / RenderRoute+                -- paths; a bare 'ConT' here is a kind error for a+                -- parameterized site.+                mkRouteAttrsInstanceFor+                    appCxt+                    (applyTyArgs (ConT (mkName target)) tyArgs)+                    target+                    (rfResources foundation)++    dispatchDec <-+        mkDispatchInstance opts (rfSite foundation) appCxt tyArgs f (rfResources foundation)+    parseRouteDec <-+        mkParseRouteInstanceOpts opts tyArgs appCxt (rfSite foundation) (rfResources foundation)     let rname = mkName $ "resources" ++ namestr-    eres <- lift resS-    let resourcesDec =-            [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)-            , FunD rname [Clause [] (NormalB eres) []]-            ]+    resourcesDec <-+        if shouldCreateResources opts+            then do+                eres <- lift resS+                pure+                    [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)+                    , FunD rname [Clause [] (NormalB eres) []]+                    ]+            else do+                pure []     let dataDec = concat-            [ [parseRoute]+            [ parseRouteDec             , renderRouteDec-            , [routeAttrsDec]-            , resourcesDec-            , if isSub then [] else masterTypeSyns vns site+            , routeAttrsDec+            , if isJust (roFocusOnNestedRoute opts) then [] else resourcesDec+            , if isSub || isJust (roFocusOnNestedRoute opts)+                then []+                else masterTypeSyns argvars (rfSite foundation)             ]     return (dataDec, dispatchDec) -mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b-mkMDS f rh = MkDispatchSettings-    { mdsRunHandler = rh-    , mdsSubDispatcher =-        [|\parentRunner getSub toParent env -> yesodSubDispatch-                                 YesodSubRunnerEnv-                                    { ysreParentRunner = parentRunner-                                    , ysreGetSub = getSub-                                    , ysreToParentRoute = toParent-                                    , ysreParentEnv = env-                                    }-                              |]-    , mdsGetPathInfo = [|W.pathInfo|]-    , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]-    , mdsMethod = [|W.requestMethod|]-    , mds404 = [|void notFound|]-    , mds405 = [|void badMethod|]-    , mdsGetHandler = defaultGetHandler-    , mdsUnwrapper = f-    }+-- | Generate both 'YesodSubDispatch' and 'YesodSubDispatchNested' instances+-- for a parameterized subsite. This is the subsite equivalent of using+-- @mkYesod@ for top-level sites.+--+-- Usage:+--+-- @+-- mkYesodSubDispatchInstance "(MyClass a) => MySub a" resourcesMySub+-- @+--+-- This generates:+--+-- 1. A 'YesodSubDispatch' instance using 'mkYesodSubDispatch'+-- 2. 'YesodSubDispatchNested' instances for any nested route fragments+--+-- The generated instances quantify over the @master@ site and constrain it+-- only through the subsite's own class. For a parameterized subsite this+-- normally means the subsite's class carries a @subsite -> master@ functional+-- dependency (so @master@ is determined) and the using module enables+-- @UndecidableInstances@ (the instance contexts mention type-family+-- applications and non-variable arguments), along with @FlexibleContexts@,+-- @FlexibleInstances@, @MultiParamTypeClasses@ and @TypeFamilies@. The nested+-- route datatype must also declare exactly as many type parameters as the+-- subsite has type arguments (see the arity note below).+--+-- @since 1.7.0.0+mkYesodSubDispatchInstance+    :: String                -- ^ Foundation type with optional context, e.g. @"(MyClass a) => MySub a"@+    -> [ResourceTree String] -- ^ Resources (e.g. @resourcesMySub@)+    -> Q [Dec]+mkYesodSubDispatchInstance = mkYesodSubDispatchInstanceOpts defaultOpts --- | If the generation of @'YesodDispatch'@ instance require finer--- control of the types, contexts etc. using this combinator. You will--- hardly need this generality. However, in certain situations, like--- when writing library/plugin for yesod, this combinator becomes--- handy.-mkDispatchInstance :: Type                      -- ^ The master site type-                   -> Cxt                       -- ^ Context of the instance-                   -> (Exp -> Q Exp)            -- ^ Unwrap handler-                   -> [ResourceTree c]          -- ^ The resource-                   -> DecsQ-mkDispatchInstance master cxt f res = do-    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res-    let thisDispatch = FunD 'yesodDispatch [clause']-    return [instanceD cxt yDispatch [thisDispatch]]-  where-    yDispatch = ConT ''YesodDispatch `AppT` master+-- | Like 'mkYesodSubDispatchInstance', but takes a 'RouteOpts' so a subsite can+-- control nested-route generation — most usefully 'setNestedRouteFallthrough'+-- (which 'mkYesodSubDispatchInstance' leaves at its default of 'False'). The+-- flag is threaded into both the @yesodSubDispatch@ body (so the subsite's own+-- top-level parent clauses fall through to later siblings on an inner miss) and+-- the generated @YesodSubDispatchNested@ fragment instances.+--+-- @since 1.7.0.0+mkYesodSubDispatchInstanceOpts+    :: RouteOpts+    -> String                -- ^ Foundation type with optional context, e.g. @"(MyClass a) => MySub a"@+    -> [ResourceTree String] -- ^ Resources (e.g. @resourcesMySub@)+    -> Q [Dec]+mkYesodSubDispatchInstanceOpts opts nameStr resS = do+    -- Parse the name string to extract context, type name, and type args+    -- (the same parser the top-level mkYesod entry points use).+    (namestr, mtys, appCxt') <- parseYesodNameQ nameStr -mkYesodSubDispatch :: [ResourceTree a] -> Q Exp-mkYesodSubDispatch res = do-    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res-    inner <- newName "inner"-    let innerFun = FunD inner [clause']-    helper <- newName "helper"-    let fun = FunD helper-                [ Clause-                    []-                    (NormalB $ VarE inner)-                    [innerFun]-                ]-    return $ LetE [fun] (VarE helper)+    appCxt <- buildAppCxt appCxt' -instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing+    foundation <- resolveFoundation namestr mtys resS+    -- The explicitly-written args plus the fresh vars filling the reified+    -- arity. Both are part of the subsite's full application ('rfSite'), so both+    -- must travel in the 'TyArgs' handed to 'discoveryMode' and the generators+    -- — otherwise a parameterized subsite invoked without explicit type args+    -- (e.g. @mkYesodSubDispatchInstance "MySub"@ for @MySub a@) would be+    -- misclassified as monomorphic and emit ill-scoped nested instances. This+    -- mirrors the 'fillNames' fix in 'mkYesodGeneralOpts'.+    let fillNames = fmap (\v -> (VarT v, v)) (rfFillVars foundation)+        tyArgs = toTyArgs (rfBoundNames foundation ++ fillNames)++    -- Generate the YesodSubDispatch instance+    masterN <- newName "master"+    let masterT = VarT masterN+        -- Thread the opts (in particular 'roNestedRouteFallthrough') into the+        -- generated @yesodSubDispatch@ body so a subsite's own top-level parent+        -- clauses honor 'setNestedRouteFallthrough', matching the top-level+        -- 'mkTopLevelDispatchInstance' path. 'GeneratesNestedInstances': this+        -- entry point emits a 'YesodSubDispatchNested' instance per parent in+        -- this same splice (below), so the flat @yesodSubDispatch@ body+        -- delegates each parent to that instance instead of inlining the+        -- subtree dispatch (which the nested instance would re-emit), avoiding+        -- the doubled codegen. This mirrors 'mkTopLevelDispatchInstance' on the+        -- top-level path. Standalone 'mkYesodSubDispatch'/'mkYesodSubDispatchWith'+        -- stay at 'NoSameSpliceNestedInstances'.+        subDispatchExp =+            mkYesodSubDispatchWithDelegate+                GeneratesNestedInstances+                opts+                (rfResources foundation)+    subDispatchBody <- subDispatchExp+    let yesodSubDispatchInst = instanceD+            appCxt+            (ConT ''YesodSubDispatch `AppT` rfSite foundation `AppT` masterT)+            [ FunD 'yesodSubDispatch+                [ Clause [] (NormalB subDispatchBody) [] ]+            ]++    -- The top-level nested parents, each of which gets a+    -- YesodSubDispatchNested instance generated below.+    let nestedNames = [ n | ResourceParent n _ _ _ _ <- rfResources foundation ]++    nestedInstances <- fmap mconcat $ forM nestedNames $ \nestedName -> do+        -- Resolve the nested datatype once and reuse it for both the+        -- "instance already exists?" probe and the arity check below.+        -- 'nestedInstanceExists' saturates by the datatype's own reified arity,+        -- so it can't throw a kind error on an arity-mismatched in-scope+        -- datatype — which is exactly the misuse the 'checkNestedSubArity'+        -- below diagnoses. That keeps the friendly arity check reachable+        -- instead of being preempted by a cryptic kind error from the probe.+        rc <- resolveRouteCon nestedName+        instanceExists <- nestedInstanceExists ''YesodSubDispatchNested rc+        if instanceExists+            then pure []+            else do+                -- This API targets parameterized subsites whose nested subroute+                -- datatypes carry the parent's type arguments (the subsite's+                -- 'tyArgs' are applied to the nested datatype directly below).+                -- Guard the misuse where the+                -- subsite is parameterized but the nested datatype is not:+                -- otherwise applying the subsite's type args to a kind-'Type'+                -- datatype produces a cryptic kind error from generated code.+                -- Only check when the datatype actually resolved — an+                -- unresolved name has no knowable arity (defaulting it to 0+                -- would wrongly report "0 type parameter(s)"), and downstream+                -- codegen reports the not-in-scope case on its own.+                assertNestedSubArity+                    SubsiteCall+                    (SubsiteName namestr)+                    (SubsiteArity (tyArgsArity tyArgs))+                    rc+                -- Call the worker directly with the foundation's+                -- already-parsed 'Type' resources, rather than re-parsing the+                -- 'String' resources through the public 'mkNestedSubDispatchInstance'.+                -- The generator applies 'tyArgs' to the nested datatype directly+                -- and never consults 'roParameterizedSubroute' (it only reads+                -- 'roNestedRouteFallthrough'), so passing 'opts' through+                -- unchanged is correct — forcing 'setParameterizedSubroute' here+                -- was a no-op.+                mkNestedDispatchInstanceWith SubsiteNested Nothing+                    opts+                    nestedName appCxt tyArgs return (rfResources foundation)++    return $ yesodSubDispatchInst : nestedInstances
src/Yesod/Core/Internal/Util.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Yesod.Core.Internal.Util     ( putTime     , getTime
src/Yesod/Core/Json.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Yesod.Core.Json     ( -- * Convert from a JSON value       defaultLayoutJson@@ -32,6 +32,9 @@     , jsonOrRedirect     , jsonEncodingOrRedirect     , acceptsJson++      -- * Checking if data is JSON+    , contentTypeHeaderIsJson     ) where  import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)@@ -134,8 +137,8 @@ parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseCheckJsonBody = do     mct <- lookupHeader "content-type"-    case fmap (B8.takeWhile (/= ';')) mct of-        Just "application/json" -> parseInsecureJsonBody+    case fmap contentTypeHeaderIsJson mct of+        Just True -> parseInsecureJsonBody         _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct  -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse@@ -218,3 +221,12 @@             .  listToMaybe             .  reqAccept)            `liftM` getRequest++-- | Given the @Content-Type@ header, returns if it is JSON.+--+-- This function is currently a simple check for @application/json@, but in the future may check for+-- alternative representations such as @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@.+--+-- @since 1.6.17+contentTypeHeaderIsJson :: B8.ByteString -> Bool+contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json"
src/Yesod/Core/TypeCache.hs view
src/Yesod/Core/Types.hs view
@@ -1,16 +1,25 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-}-module Yesod.Core.Types where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-} +module Yesod.Core.Types (+    module Yesod.Core.Types+  , module Yesod.Core.Types.ErrorResponse+  , module Yesod.Core.Types.Content+  , module Yesod.Core.Types.TypedContent+  , module Yesod.Core.Types.HandlerContents++  , module Yesod.Core.Internal.Util+  , module Yesod.Routes.Class+  , module Yesod.Core.TypeCache+  ) where+ import Data.Aeson (ToJSON) import qualified Data.ByteString.Builder            as BB import           Control.Arrow                      (first)@@ -29,16 +38,16 @@ import           Data.Map                           (Map, unionWith) import qualified Data.Map                           as Map import           Data.Monoid                        (Endo (..), Last (..))-import           Data.Semigroup                     (Semigroup(..)) import           Data.Serialize                     (Serialize (..),                                                      putByteString) import           Data.String                        (IsString (fromString)) import           Data.Text                          (Text) import qualified Data.Text                          as T+import           Data.Text.Encoding import qualified Data.Text.Lazy.Builder             as TBuilder import           Data.Time                          (UTCTime)-import           Data.Typeable                      (Typeable) import           GHC.Generics                       (Generic)+import qualified GHC.Int                            as I import           Language.Haskell.TH.Syntax         (Loc) import qualified Network.HTTP.Types                 as H import           Network.Wai                        (FilePart,@@ -57,8 +66,13 @@ import Control.DeepSeq (NFData (rnf)) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Control.Monad.Logger (MonadLoggerIO (..))-import UnliftIO (MonadUnliftIO (..), UnliftIO (..))+import UnliftIO (MonadUnliftIO (..), SomeException) +import Yesod.Core.Types.ErrorResponse+import Yesod.Core.Types.Content+import Yesod.Core.Types.TypedContent+import Yesod.Core.Types.HandlerContents+ -- Sessions type SessionMap = Map Text ByteString @@ -184,6 +198,11 @@       --       -- Since 1.2.0     , rheMaxExpires :: !Text++      -- | @since 1.6.24.0+      --   catch function for rendering 500 pages on exceptions.+      --   by default this is catch from unliftio (rethrows all async exceptions).+    , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m =>  m a -> (SomeException -> m a) -> m a)     }  data HandlerData child site = HandlerData@@ -198,7 +217,13 @@     , yreSite           :: !site     , yreSessionBackend :: !(Maybe SessionBackend)     , yreGen            :: !(IO Int)-    -- ^ Generate a random number+    -- ^ Generate a random number uniformly distributed in the full+    -- range of 'Int'.+    --+    -- Note: Before 1.6.20, the default value generates pseudo-random+    -- number in an unspecified range. The range size may not be a power+    -- of 2. Since 1.6.20, the default value uses a secure entropy source+    -- and generates in the full range of 'Int'.     , yreGetMaxExpires  :: !(IO Text)     } @@ -233,7 +258,7 @@  -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as--- the 'HandlerT' monad and template haskell code should hide it away.+-- the 'HandlerFor' monad and template haskell code should hide it away. type YesodApp = YesodRequest -> ResourceT IO YesodResponse  -- | A generic widget, allowing specification of both the subsite and master@@ -251,9 +276,6 @@  instance a ~ () => Monoid (WidgetFor site a) where     mempty = return ()-#if !(MIN_VERSION_base(4,11,0))-    mappend = (<>)-#endif instance a ~ () => Semigroup (WidgetFor site a) where     x <> y = x >> y @@ -285,26 +307,18 @@ -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent-    { pageTitle :: !Html-    , pageHead  :: !(HtmlUrl url)-    , pageBody  :: !(HtmlUrl url)+    { pageTitle       :: !Html+    , pageDescription :: !(Maybe Text)+    , pageHead        :: !(HtmlUrl url)+    , pageBody        :: !(HtmlUrl url)     } -data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.-             | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())-             | ContentFile !FilePath !(Maybe FilePart)-             | ContentDontEvaluate !Content--data TypedContent = TypedContent !ContentType !Content- type RepHtml = Html {-# DEPRECATED RepHtml "Please use Html instead" #-} newtype RepJson = RepJson Content newtype RepPlain = RepPlain Content newtype RepXml = RepXml Content -type ContentType = ByteString -- FIXME Text?- -- | Wrapper around types so that Handlers can return a domain type, even when -- the data will eventually be encoded as JSON. -- Example usage in a type signature:@@ -325,17 +339,6 @@ -- Since 1.1.0 newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a } --- | Responses to indicate some form of an error occurred.-data ErrorResponse =-      NotFound-    | InternalError !Text-    | InvalidArgs ![Text]-    | NotAuthenticated-    | PermissionDenied !Text-    | BadMethod !H.Method-    deriving (Show, Eq, Typeable, Generic)-instance NFData ErrorResponse- ----- header stuff -- | Headers to be added to a 'Result'. data Header =@@ -366,21 +369,19 @@ data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }     deriving (Show, Eq) newtype Title = Title { unTitle :: Html }+newtype Description = Description { unDescription :: Text }  newtype Head url = Head (HtmlUrl url)-    deriving Monoid-instance Semigroup (Head url) where-  (<>) = mappend+    deriving (Semigroup, Monoid) newtype Body url = Body (HtmlUrl url)-    deriving Monoid-instance Semigroup (Body url) where-  (<>) = mappend+    deriving (Semigroup, Monoid)  type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder  data GWData a = GWData     { gwdBody        :: !(Body a)     , gwdTitle       :: !(Last Title)+    , gwdDescription :: !(Last Description)     , gwdScripts     :: !(UniqueList (Script a))     , gwdStylesheets :: !(UniqueList (Stylesheet a))     , gwdCss         :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type@@ -388,40 +389,18 @@     , gwdHead        :: !(Head a)     } instance Monoid (GWData a) where-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty-#if !(MIN_VERSION_base(4,11,0))-    mappend = (<>)-#endif+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty instance Semigroup (GWData a) where-    GWData a1 a2 a3 a4 a5 a6 a7 <>-      GWData b1 b2 b3 b4 b5 b6 b7 = GWData+    GWData a1 a2 a3 a4 a5 a6 a7 a8 <>+      GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData         (mappend a1 b1)         (mappend a2 b2)         (mappend a3 b3)         (mappend a4 b4)-        (unionWith mappend a5 b5)-        (mappend a6 b6)+        (mappend a5 b5)+        (unionWith mappend a6 b6)         (mappend a7 b7)--data HandlerContents =-      HCContent !H.Status !TypedContent-    | HCError !ErrorResponse-    | HCSendFile !ContentType !FilePath !(Maybe FilePart)-    | HCRedirect !H.Status !Text-    | HCCreated !Text-    | HCWai !W.Response-    | HCWaiApp !W.Application-    deriving Typeable--instance Show HandlerContents where-    show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)-    show (HCError e) = "HCError " ++ show e-    show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)-    show (HCRedirect s t) = "HCRedirect " ++ show (s, t)-    show (HCCreated t) = "HCCreated " ++ show t-    show (HCWai _) = "HCWai"-    show (HCWaiApp _) = "HCWaiApp"-instance Exception HandlerContents+        (mappend a8 b8)  -- Instances for WidgetFor instance Applicative (WidgetFor site) where@@ -440,9 +419,8 @@     primitive = liftIO . primitive -- | @since 1.4.38 instance MonadUnliftIO (WidgetFor site) where-  {-# INLINE askUnliftIO #-}-  askUnliftIO = WidgetFor $ \wd ->-                return (UnliftIO (flip unWidgetFor wd))+  {-# INLINE withRunInIO #-}+  withRunInIO inner = WidgetFor $ \x -> inner $ flip unWidgetFor x instance MonadReader (WidgetData site) (WidgetFor site) where     ask = WidgetFor return     local f (WidgetFor g) = WidgetFor $ g . f@@ -460,7 +438,7 @@ instance MonadLoggerIO (WidgetFor site) where     askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler --- Instances for HandlerT+-- Instances for HandlerFor instance Applicative (HandlerFor site) where     pure = HandlerFor . const . return     (<*>) = ap@@ -479,9 +457,8 @@  -- | @since 1.4.38 instance MonadUnliftIO (HandlerFor site) where-  {-# INLINE askUnliftIO #-}-  askUnliftIO = HandlerFor $ \r ->-                return (UnliftIO (flip unHandlerFor r))+  {-# INLINE withRunInIO #-}+  withRunInIO inner = HandlerFor $ \x -> inner $ flip unHandlerFor x  instance MonadThrow (HandlerFor site) where     throwM = liftIO . throwM@@ -498,9 +475,6 @@  instance Monoid (UniqueList x) where     mempty = UniqueList id-#if !(MIN_VERSION_base(4,11,0))-    mappend = (<>)-#endif instance Semigroup (UniqueList x) where     UniqueList x <> UniqueList y = UniqueList $ x . y @@ -552,9 +526,8 @@  -- | @since 1.4.38 instance MonadUnliftIO (SubHandlerFor child master) where-  {-# INLINE askUnliftIO #-}-  askUnliftIO = SubHandlerFor $ \r ->-                return (UnliftIO (flip unSubHandlerFor r))+  {-# INLINE withRunInIO #-}+  withRunInIO inner = SubHandlerFor $ \x -> inner $ flip unSubHandlerFor x  instance MonadThrow (SubHandlerFor child master) where     throwM = liftIO . throwM
+ src/Yesod/Core/Types/Content.hs view
@@ -0,0 +1,21 @@+module Yesod.Core.Types.Content where++import qualified Data.ByteString.Builder as BB+import Control.Monad.Trans.Resource (ResourceT)+import Data.Conduit (Flush, ConduitT)+import Network.Wai (FilePart)++data Content+    = ContentBuilder !BB.Builder !(Maybe Int)+    -- ^ The content and optional content length.+    --+    -- Note that, despite @Builder@'s laziness, this is entirely forced+    -- into memory by default in order to catch imprecise exceptions+    -- before beginning to respond. If you are confident you don't have+    -- imprecise exceptions, you may disable this by wrapping the+    -- `ToContent` data in `DontFullyEvaluate`.+    | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())+    | ContentFile !FilePath !(Maybe FilePart)+    | ContentDontEvaluate !Content+    -- ^ Used internally to wrap @ContentBuilder@s to disable forcing+    -- them. No effect on other @Content@.
+ src/Yesod/Core/Types/ErrorResponse.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveGeneric #-}++module Yesod.Core.Types.ErrorResponse where++import GHC.Generics (Generic)+import Data.Text+import Control.DeepSeq (NFData)+import qualified Network.HTTP.Types as H++-- | Responses to indicate some form of an error occurred.+data ErrorResponse =+      NotFound+        -- ^ The requested resource was not found.+        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.+        -- HTTP status: 404.+    | InternalError !Text+        -- ^ Some sort of unexpected exception.+        -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.+        -- HTTP status: 500.+    | InvalidArgs ![Text]+        -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.+        -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.+        -- HTTP status: 400.+    | NotAuthenticated+        -- ^ Indicates the user is not logged in.+        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.+        -- HTTP code: 401.+    | PermissionDenied !Text+        -- ^ Indicates the user doesn't have permission to access the requested resource.+        -- This is thrown when 'isAuthorized' returns 'Unauthorized'.+        -- HTTP code: 403.+    | BadMethod !H.Method+        -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)+        -- HTTP code: 405.+    deriving (Show, Eq, Generic)++instance NFData ErrorResponse
+ src/Yesod/Core/Types/HandlerContents.hs view
@@ -0,0 +1,39 @@+module Yesod.Core.Types.HandlerContents+  (+    HandlerContents (..)+  ) where++import Control.Exception (Exception)+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Network.HTTP.Types as H+import qualified Network.Wai as W+import Yesod.Core.Types.ErrorResponse+import Yesod.Core.Types.TypedContent (ContentType, TypedContent (..), typedContentToSnippet)++data HandlerContents =+      HCContent !H.Status !TypedContent+    | HCError !ErrorResponse+    | HCSendFile !ContentType !FilePath !(Maybe W.FilePart)+    | HCRedirect !H.Status !T.Text+    | HCCreated !T.Text+    | HCWai !W.Response+    | HCWaiApp !W.Application++instance Show HandlerContents where+    show (HCContent status tc@(TypedContent t _))+      = mconcat [ "HCContent "+                , show (status, t)+                , " ("+                , fromMaybe "" $ TL.unpack <$> typedContentToSnippet tc 1000+                , ")"+                ]+    show (HCError e) = "HCError " ++ show e+    show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)+    show (HCRedirect s t) = "HCRedirect " ++ show (s, t)+    show (HCCreated t) = "HCCreated " ++ show t+    show (HCWai _) = "HCWai"+    show (HCWaiApp _) = "HCWaiApp"++instance Exception HandlerContents
+ src/Yesod/Core/Types/TypedContent.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Core.Types.TypedContent+  (+    ContentType+  , TypedContent (..)+  , typedContentToSnippet+  ) where++import Control.Applicative ((<|>))+import Control.Monad (void, guard)+import Data.Maybe (fromMaybe)++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as BB++import qualified Data.Int as I++#if MIN_VERSION_text(2,1,0)+import qualified Data.Text.Encoding as TE (decodeASCIIPrefix)+#else+import qualified Data.Text.Encoding as TE (decodeLatin1)+#endif+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as LE (decodeUtf8With, decodeLatin1)+import qualified Data.Text.Encoding.Error as EE (lenientDecode)++import qualified Data.Encoding as Enc+import qualified Data.Encoding.GB18030 as Enc+import qualified Data.Encoding.CP1251 as Enc+import qualified Data.Encoding.ShiftJIS as Enc+import qualified Data.Encoding.CP932 as Enc++import qualified Network.Wai.Parse as NWP++import Yesod.Core.Types.Content (Content (..))++type ContentType = B.ByteString -- FIXME Text?+data TypedContent = TypedContent !ContentType !Content++decoderForCharset :: Maybe B.ByteString -> L.ByteString -> TL.Text+decoderForCharset (Just encodingSymbol)+  | encodingSymbol == "utf-8" =+      LE.decodeUtf8With EE.lenientDecode+  | encodingSymbol == "US-ASCII" =+#if MIN_VERSION_text(2,1,0)+      TL.fromStrict . fst . TE.decodeASCIIPrefix . L.toStrict+#else+      TL.fromStrict . TE.decodeLatin1 . L.toStrict+#endif+  | encodingSymbol == "latin1" =+      LE.decodeLatin1+  | encodingSymbol == "GB18030" =+      TL.pack . Enc.decodeLazyByteString Enc.GB18030+  | encodingSymbol == "windows-1251" =+      TL.pack . Enc.decodeLazyByteString Enc.CP1251+  | encodingSymbol == "Shift_JIS" =+      TL.pack . Enc.decodeLazyByteString Enc.ShiftJIS+  | encodingSymbol == "Windows-31J" =+      TL.pack . Enc.decodeLazyByteString Enc.CP932+  | otherwise =+      LE.decodeUtf8With EE.lenientDecode+decoderForCharset Nothing = LE.decodeUtf8With EE.lenientDecode++decodeForContentType :: ContentType -> L.ByteString -> Maybe TL.Text+decodeForContentType ct bytes = do+  let (t, params) =+        NWP.parseContentType ct+      charset =+        lookup "charset" params+      typeIsText =+        B.isPrefixOf "text" t+            || B.isPrefixOf "application/json" t+            || B.isPrefixOf "application/rss"  t+            || B.isPrefixOf "application/atom" t+      decoder = decoderForCharset charset+  void charset <|> guard typeIsText+  pure $ decoder bytes++contentToSnippet :: Content -> I.Int64 -> Maybe L.ByteString+contentToSnippet (ContentBuilder builder maybeLength) maxLength =+  pure $ truncatedText <> excessLengthMsg+  where+    truncatedText = L.take maxLength $ BB.toLazyByteString builder+    excessLength = fromMaybe 0 $ (subtract $ fromIntegral maxLength) <$> maybeLength+    excessLengthMsg = case excessLength > 0 of+      False -> ""+      True -> "...+ " <> BB.toLazyByteString (BB.intDec excessLength)+contentToSnippet (ContentSource _) _ = Nothing+contentToSnippet (ContentFile _ _) _ = Nothing+contentToSnippet (ContentDontEvaluate _) _ = Nothing++-- | Represents TypedContent as a String, rendering at most a specified number of+-- bytes of the content, and annotating it with the remaining length. Returns Nothing+-- if the content type indicates the content is binary data.+--+-- @since 1.6.28.0+typedContentToSnippet :: TypedContent -> I.Int64 -> Maybe TL.Text+typedContentToSnippet (TypedContent t c) maxLength = decodeForContentType t =<< contentToSnippet c maxLength
src/Yesod/Core/Widget.hs view
@@ -1,13 +1,16 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-}+ -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Core.Widget@@ -29,6 +32,12 @@       -- ** Head of page     , setTitle     , setTitleI+    , setDescription+    , setDescriptionI+    , setDescriptionIdemp+    , setDescriptionIdempI+    , setOGType+    , setOGImage       -- ** CSS     , addStylesheet     , addStylesheetAttrs@@ -49,7 +58,7 @@     , asWidgetT     ) where -import Data.Monoid+import Data.Monoid (Last (..)) import qualified Text.Blaze.Html5 as H import Text.Hamlet import Text.Cassius@@ -58,6 +67,7 @@ import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) import Text.Shakespeare.I18N (RenderMessage) import Data.Text (Text)+import Data.Kind (Type) import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)@@ -71,7 +81,7 @@ import Yesod.Core.Types import Yesod.Core.Class.Handler -type WidgetT site (m :: * -> *) = WidgetFor site+type WidgetT site (m :: Type -> Type) = WidgetFor site {-# DEPRECATED WidgetT "Use WidgetFor directly" #-}  preEscapedLazyText :: TL.Text -> Html@@ -81,19 +91,19 @@     toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()  instance render ~ RY site => ToWidget site (render -> Html) where-    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty+    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty instance render ~ RY site => ToWidget site (render -> Css) where     toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x instance ToWidget site Css where     toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where-    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance ToWidget site CssBuilder where-    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty instance render ~ RY site => ToWidget site (render -> Javascript) where-    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty instance ToWidget site Javascript where-    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where     toWidget = liftWidget instance ToWidget site Html where@@ -124,9 +134,9 @@ instance ToWidgetMedia site Css where     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where-    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty instance ToWidgetMedia site CssBuilder where-    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty  class ToWidgetBody site a where     toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()@@ -144,7 +154,7 @@     toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()  instance render ~ RY site => ToWidgetHead site (render -> Html) where-    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head+    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head instance render ~ RY site => ToWidgetHead site (render -> Css) where     toWidgetHead = toWidget instance ToWidgetHead site Css where@@ -160,18 +170,133 @@ instance ToWidgetHead site Html where     toWidgetHead = toWidgetHead . const --- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.+-- | Set the page title.+--+-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set+-- values.+--+-- SEO Notes:+--+--    * Title tags are the second most important on-page factor for SEO, after+--      content+--    * Every page should have a unique title tag+--    * Start your title tag with your main targeted keyword+--    * Don't stuff your keywords+--    * Google typically shows 55-64 characters, so aim to keep your title+--      length under 60 characters setTitle :: MonadWidget m => Html -> m ()-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty --- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.+-- | Set the localised page title.+--+-- n.b. See comments for @setTitle@ setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () setTitleI msg = do     mr <- getMessageRender     setTitle $ toHtml $ mr msg +-- | Add description meta tag to the head of the page+--+-- Google does not use the description tag as a ranking signal, but the+-- contents of this tag will likely affect your click-through rate since it+-- shows up in search results.+--+-- The average length of the description shown in Google's search results is+-- about 160 characters on desktop, and about 130 characters on mobile, at time+-- of writing.+--+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/+--+-- @since 1.6.18+setDescription :: MonadWidget m => Text -> m ()+setDescription description =+    toWidgetHead $ [hamlet|<meta name=description content=#{description}>|]++{-# WARNING setDescription+  [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead"+  , "Multiple calls to setDescription will insert multiple meta tags in the page head."+  , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \+    \may need to change your layout to include pageDescription."+  ]+#-}++-- | Add translated description meta tag to the head of the page+--+-- n.b. See comments for @setDescription@.+--+-- @since 1.6.18+setDescriptionI+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)+  => msg -> m ()+setDescriptionI msg = do+    mr <- getMessageRender+    toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|]++{-# WARNING setDescriptionI+  [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead"+  , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head."+  , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \+    \may need to change your layout to include pageDescription."+  ]+#-}++-- | Add description meta tag to the head of the page+--+-- Google does not use the description tag as a ranking signal, but the+-- contents of this tag will likely affect your click-through rate since it+-- shows up in search results.+--+-- The average length of the description shown in Google's search results is+-- about 160 characters on desktop, and about 130 characters on mobile, at time+-- of writing.+--+-- Unlike 'setDescription', this version is *idempotent* - calling it multiple+-- times will result in only a single description meta tag in the head.+--+-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/+--+-- @since 1.6.23+setDescriptionIdemp :: MonadWidget m => Text -> m ()+setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty++-- | Add translated description meta tag to the head of the page+--+-- n.b. See comments for @setDescriptionIdemp@.+--+-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple+-- times will result in only a single description meta tag in the head.+--+-- @since 1.6.23+setDescriptionIdempI+  :: (MonadWidget m, RenderMessage (HandlerSite m) msg)+  => msg -> m ()+setDescriptionIdempI msg = do+    mr <- getMessageRender+    setDescriptionIdemp $ mr msg++-- | Add OpenGraph type meta tag to the head of the page+--+-- See all available OG types here: https://ogp.me/#types+--+-- @since 1.6.18+setOGType :: MonadWidget m => Text -> m ()+setOGType a = toWidgetHead $ [hamlet|<meta property="og:type" content=#{a}>|]++-- | Add OpenGraph image meta tag to the head of the page+--+-- Best practices:+--+--    * Use custom images for shareable pages, e.g., homepage, articles, etc.+--    * Use your logo or any other branded image for the rest of your pages.+--    * Use images with a 1.91:1 ratio and minimum recommended dimensions of+--      1200x630 for optimal clarity across all devices.+--+-- Source: https://ahrefs.com/blog/open-graph-meta-tags/+--+-- @since 1.6.18+setOGImage :: MonadWidget m => Text -> m ()+setOGImage a = toWidgetHead $ [hamlet|<meta property="og:image" content=#{a}>|]+ -- | Link to the specified local stylesheet. addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m () addStylesheet = flip addStylesheetAttrs []@@ -181,7 +306,7 @@                    => Route (HandlerSite m)                    -> [(Text, Text)]                    -> m ()-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty  -- | Link to the specified remote stylesheet. addStylesheetRemote :: MonadWidget m => Text -> m ()@@ -189,7 +314,7 @@  -- | Link to the specified remote stylesheet. addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty  addStylesheetEither :: MonadWidget m                     => Either (Route (HandlerSite m)) Text@@ -207,7 +332,7 @@  -- | Link to the specified local script. addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()-addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty+addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty  -- | Link to the specified remote script. addScriptRemote :: MonadWidget m => Text -> m ()@@ -215,7 +340,7 @@  -- | Link to the specified remote script. addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty+addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty  whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
src/Yesod/Routes/Class.hs view
@@ -1,13 +1,23 @@-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+ module Yesod.Routes.Class     ( RenderRoute (..)     , ParseRoute (..)     , RouteAttrs (..)+    , -- * For nested routes and splitting files+      RenderRouteNested (..)+    , ParseRouteNested (..)+    , RouteAttrsNested (..)+    , WithParentArgs (..)     ) where  import Data.Text (Text) import Data.Set (Set)+import Data.Kind (Type)  class Eq (Route a) => RenderRoute a where     -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> associated with a site argument.@@ -15,10 +25,97 @@     renderRoute :: Route a                 -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. +-- | This datatype wraps up the 'ParentArgs' for a route fragment with the+-- route fragment itself. A route fragment with its parent arguments can+-- be rendered and dispatched on.+--+-- @since 1.7.0.0+data WithParentArgs a = WithParentArgs+    { theParentArgs :: ParentArgs a+    , parentArgsFor :: a+    }++deriving stock instance (Eq (ParentArgs a), Eq a) => Eq (WithParentArgs a)++instance (Eq (ParentArgs a), RenderRouteNested a) => RenderRouteNested (WithParentArgs a) where+    type ParentSite (WithParentArgs a) = ParentSite a+    type ParentArgs (WithParentArgs a) = ()++    renderRouteNested () (WithParentArgs parentArgs a) =+        renderRouteNested parentArgs a++-- | This class acts as a delegation class for 'RenderRoute' on nested+-- route fragments.+--+-- @since 1.7.0.0+class Eq a => RenderRouteNested a where+    -- | The site type for a given route fragment.+    --+    -- @since 1.7.0.0+    type ParentSite a :: Type++    -- | The 'ParentArgs' are the route fragments necessary to call the+    -- dispatched route that are not part of the route fragments used in+    -- parsing the route.+    --+    -- @since 1.7.0.0+    type ParentArgs a :: Type+    type ParentArgs a = ()++    -- | Render the fragment of the route. To form a complete route, you'll+    -- need to 'mappend' this with the result from the parent 'renderRoute'+    -- or 'renderRouteNested' call.+    --+    -- @since 1.7.0.0+    renderRouteNested :: ParentArgs a -> a -> ([Text], [(Text, Text)])++instance (RenderRoute site) => RenderRouteNested (Route site) where+    type ParentSite (Route site) = site+    type ParentArgs (Route site) = ()++    renderRouteNested () a = renderRoute a+ class RenderRoute a => ParseRoute a where     parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.                -> Maybe (Route a) +-- | Like 'RenderRouteNested', this acts as a delegation class for nested+-- route fragments.+--+-- Note that 'parseRouteNested' and 'renderRouteNested' are /not/ inverses, by+-- design. 'renderRouteNested' consumes the @'ParentArgs' a@ (the parent's+-- dynamic pieces) to produce a complete path, whereas 'parseRouteNested'+-- recovers only the fragment @a@ and never the 'ParentArgs' — the parent is+-- responsible for those. So @'parseRouteNested' p@ followed by+-- @'renderRouteNested' args@ round-trips the /fragment/ portion of @p@ only,+-- with @args@ supplied separately by the caller.+--+-- @since 1.7.0.0+class RenderRouteNested a => ParseRouteNested a where+    -- | Parse a route fragment from a path. Like 'parseRoute', but produces+    -- the fragment @a@ directly rather than a complete 'Route'; the parent is+    -- responsible for constructing the full route from the result.+    --+    -- @since 1.7.0.0+    parseRouteNested+        :: ([Text], [(Text, Text)])+        -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.+        --+        -- Unlike for 'parseRoute', this will not include URL fragments as+        -- part of parent routes. It is expected that parents will take the+        -- resulting @a@ and construct the parent from that.+        -> Maybe a+ class RenderRoute a => RouteAttrs a where     routeAttrs :: Route a                -> Set Text -- ^ A set of <http://www.yesodweb.com/book/route-attributes attributes associated with the route>.++-- | Like 'RenderRouteNested', this acts as a delegation class for nested+-- route fragments to provide 'RouteAttrs'.+--+-- @since 1.7.0.0+class RenderRouteNested a => RouteAttrsNested a where+    -- | Retrieve the 'RouteAttrs' for a given route fragment.+    --+    -- @since 1.7.0.0+    routeAttrsNested :: a -> Set Text
src/Yesod/Routes/Overlap.hs view
@@ -24,7 +24,7 @@         , fHasSuffix = hasSuffix $ ResourceLeaf r         , fCheck = check && resourceCheck r         }-    go names pieces check (ResourceParent newname check' newpieces children) =+    go names pieces check (ResourceParent newname check' _attrs newpieces children) =         concatMap (go names' pieces' (check && check')) children       where         names' = names . (newname:)@@ -57,10 +57,18 @@     piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY  piecesOverlap :: Piece t -> Piece t -> Bool--- Statics only match if they equal. Dynamics match with anything+-- Statics only match if they are equal. A dynamic piece is treated as+-- overlapping with anything: although at runtime a typed dynamic (e.g. an+-- 'Int') only matches inputs that parse to its type, the overlap check is+-- intentionally conservative and never inspects the dynamic-piece type — it is+-- parametric in @t@ (see 'findOverlapNames'). Reporting a possible overlap that+-- cannot actually occur is harmless; missing a real one would not be. piecesOverlap (Static x) (Static y) = x == y piecesOverlap _ _ = True +-- | The overlap check never inspects the dynamic-piece type, so this is+-- parametric in it (the reported names come from 'resourceName', always a+-- 'String'). findOverlapNames :: [ResourceTree t] -> [(String, String)] findOverlapNames =     map go . findOverlapsF . filter fCheck . concatMap Yesod.Routes.Overlap.flatten
src/Yesod/Routes/Parse.hs view
@@ -1,17 +1,21 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter+ module Yesod.Routes.Parse     ( parseRoutes     , parseRoutesFile     , parseRoutesNoCheck     , parseRoutesFileNoCheck     , parseType+    , parseTypeM     , parseTypeTree     , TypeTree (..)     , dropBracket+    , dropBracketM     , nameToType+    , isTvar     ) where  import Language.Haskell.TH.Syntax@@ -31,14 +35,20 @@ parseRoutes = QuasiQuoter { quoteExp = x }   where     x s = do-        let res = resourcesFromString s+        res <- resourcesFromString s         case findOverlapNames res of             [] -> lift res-            z -> error $ unlines $ "Overlapping routes: " : map show z+            z -> fail $ unlines $ "Overlapping routes: " : map show z +-- | Same as 'parseRoutes', but uses an external file instead of quasiquotation.+--+-- The recommended file extension is @.yesodroutes@. parseRoutesFile :: FilePath -> Q Exp parseRoutesFile = parseRoutesFileWith parseRoutes +-- | Same as 'parseRoutesNoCheck', but uses an external file instead of quasiquotation.+--+-- The recommended file extension is @.yesodroutes@. parseRoutesFileNoCheck :: FilePath -> Q Exp parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck @@ -57,20 +67,24 @@ -- | Same as 'parseRoutes', but performs no overlap checking. parseRoutesNoCheck :: QuasiQuoter parseRoutesNoCheck = QuasiQuoter-    { quoteExp = lift . resourcesFromString+    { quoteExp = \s -> resourcesFromString s >>= lift     }  -- | Converts a multi-line string to a set of resources. See documentation for--- the format of this string. This is a partial function which calls 'error' on--- invalid input.-resourcesFromString :: String -> [ResourceTree String]+-- the format of this string. Runs in any 'MonadFail' (e.g. the 'Q' monad of a+-- splice) and reports malformed input through 'fail', so diagnostics are+-- attributed to the splice rather than surfacing as a raw 'error' call stack.+resourcesFromString :: MonadFail m => String -> m [ResourceTree String] resourcesFromString =-    fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')+    fmap fst . parse 0 . filter (not . all (== ' ')) . foldr lineContinuations [] . lines . filter (/= '\r')   where-    parse _ [] = ([], [])+    parse _ [] = pure ([], [])     parse indent (thisLine:otherLines)-        | length spaces < indent = ([], thisLine : otherLines)-        | otherwise = (this others, remainder)+        | length spaces < indent = pure ([], thisLine : otherLines)+        | otherwise = do+            (this, otherLines') <- classify+            (others, remainder) <- parse indent otherLines'+            pure (this others, remainder)       where         parseAttr ('!':x) = Just x         parseAttr _ = Nothing@@ -86,54 +100,55 @@             go front (x:xs) = go (front . (x:)) xs          spaces = takeWhile (== ' ') thisLine-        (others, remainder) = parse indent otherLines'-        (this, otherLines') =-            case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of+        classify = do+            toks <- splitSpaces thisLine+            case takeWhile (not . isPrefixOf "--") toks of                 (pattern:rest0)                     | Just (constr:rest) <- stripColonLast rest0-                    , Just attrs <- mapM parseAttr rest ->-                    let (children, otherLines'') = parse (length spaces + 1) otherLines-                        children' = addAttrs attrs children-                        (pieces, Nothing, check) = piecesFromStringCheck pattern-                     in ((ResourceParent constr check pieces children' :), otherLines'')-                (pattern:constr:rest) ->-                    let (pieces, mmulti, check) = piecesFromStringCheck pattern-                        (attrs, rest') = takeAttrs rest-                        disp = dispatchFromString rest' mmulti-                     in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)-                [] -> (id, otherLines)-                _ -> error $ "Invalid resource line: " ++ thisLine+                    , Just attrs <- mapM parseAttr rest -> do+                        (children, otherLines'') <- parse (length spaces + 1) otherLines+                        let children' = addAttrs attrs children+                        (pieces, mmulti, check) <- piecesFromStringCheck pattern+                        case mmulti of+                            Nothing -> pure ()+                            Just _ -> fail $ "Parent routes cannot have a multipiece: " ++ pattern+                        pure ((ResourceParent constr check (Set.fromList attrs) pieces children' :), otherLines'')+                (pattern:constr:rest) -> do+                    (pieces, mmulti, check) <- piecesFromStringCheck pattern+                    let (attrs, rest') = takeAttrs rest+                    disp <- dispatchFromString rest' mmulti+                    pure ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)+                [] -> pure (id, otherLines)+                _ -> fail $ "Invalid resource line: " ++ thisLine  -- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive).-splitSpaces :: String -> [String]-splitSpaces "" = []-splitSpaces str = -    let (rest, piece) = parse $ dropWhile isSpace str in-    piece:(splitSpaces rest)+splitSpaces :: MonadFail m => String -> m [String]+splitSpaces "" = pure []+splitSpaces str = do+    (rest, piece) <- parse $ dropWhile isSpace str+    rest' <- splitSpaces rest+    pure (piece : rest') -    where -        parse :: String -> ( String, String)-        parse ('{':s) = fmap ('{':) $ parseBracket s-        parse (c:s) | isSpace c = (s, [])-        parse (c:s) = fmap (c:) $ parse s-        parse "" = ("", "")+    where+        parse ('{':s) = do (r, p) <- parseBracket s; pure (r, '{':p)+        parse (c:s) | isSpace c = pure (s, [])+        parse (c:s) = do (r, p) <- parse s; pure (r, c:p)+        parse "" = pure ("", "") -        parseBracket :: String -> ( String, String)-        parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str-        parseBracket ('}':s) = fmap ('}':) $ parse s-        parseBracket (c:s) = fmap (c:) $ parseBracket s-        parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str+        parseBracket ('{':_) = fail $ "Invalid resource line (nested curly bracket): " ++ str+        parseBracket ('}':s) = do (r, p) <- parse s; pure (r, '}':p)+        parseBracket (c:s) = do (r, p) <- parseBracket s; pure (r, c:p)+        parseBracket "" = fail $ "Invalid resource line (unclosed curly bracket): " ++ str -piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)-piecesFromStringCheck s0 =-    (pieces, mmulti, check)+piecesFromStringCheck :: MonadFail m => String -> m ([Piece String], Maybe String, Bool)+piecesFromStringCheck s0 = do+    let (s1, check1) = stripBang s0+    (pieces', mmulti') <- piecesFromString $ drop1Slash s1+    let pieces = map snd pieces'+        mmulti = fmap snd mmulti'+        check = check1 && all fst pieces' && maybe True fst mmulti'+    pure (pieces, mmulti, check)   where-    (s1, check1) = stripBang s0-    (pieces', mmulti') = piecesFromString $ drop1Slash s1-    pieces = map snd pieces'-    mmulti = fmap snd mmulti'-    check = check1 && all fst pieces' && maybe True fst mmulti'-     stripBang ('!':rest) = (rest, False)     stripBang x = (x, True) @@ -142,7 +157,7 @@     map goTree   where     goTree (ResourceLeaf res) = ResourceLeaf (goRes res)-    goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z)+    goTree (ResourceParent v w x y z) = ResourceParent v w x y (map goTree z)      goRes res =         res { resourceAttrs = noDupes ++ resourceAttrs res }@@ -169,36 +184,46 @@     go x y (('!':attr):rest) = go (x . (attr:)) y rest     go x y (z:rest) = go x (y . (z:)) rest -dispatchFromString :: [String] -> Maybe String -> Dispatch String+dispatchFromString :: MonadFail m => [String] -> Maybe String -> m (Dispatch String) dispatchFromString rest mmulti-    | null rest = Methods mmulti []-    | all (all isUpper) rest = Methods mmulti rest+    | null rest = pure $ Methods mmulti []+    | all (all isUpper) rest = pure $ Methods mmulti rest dispatchFromString [subTyp, subFun] Nothing =-    Subsite subTyp subFun+    pure $ Subsite subTyp subFun dispatchFromString [_, _] Just{} =-    error "Subsites cannot have a multipiece"-dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest+    fail "Subsites cannot have a multipiece"+dispatchFromString rest _ = fail $ "Invalid list of methods: " ++ show rest  drop1Slash :: String -> String drop1Slash ('/':x) = x drop1Slash x = x -piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))-piecesFromString "" = ([], Nothing)-piecesFromString x =+piecesFromString :: MonadFail m => String -> m ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))+piecesFromString "" = pure ([], Nothing)+piecesFromString x = do+    rest <- piecesFromString $ drop 1 z+    this <- pieceFromString y     case (this, rest) of-        (Left typ, ([], Nothing)) -> ([], Just typ)-        (Left _, _) -> error "Multipiece must be last piece"-        (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)+        (Left typ, ([], Nothing)) -> pure ([], Just typ)+        (Left _, _) -> fail "Multipiece must be last piece"+        (Right piece, (pieces, mtyp)) -> pure (piece:pieces, mtyp)   where     (y, z) = break (== '/') x-    this = pieceFromString y-    rest = piecesFromString $ drop 1 z  parseType :: String -> Type parseType orig =     maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig +-- | 'parseType' in 'MonadFail': a malformed type surfaces via 'fail' instead of+-- a raw 'error'. Used at the 'Language.Haskell.TH.Q' splice sites so a bad type+-- in a route definition becomes an attributed compile error. The pure+-- 'parseType' is retained for callers (e.g. tests) supplying known-good input.+--+-- @since 1.7.0.0+parseTypeM :: MonadFail m => String -> m Type+parseTypeM orig =+    maybe (fail $ "Invalid type: " ++ show orig) (pure . ttToType) $ parseTypeTree orig+ parseTypeTree :: String -> Maybe TypeTree parseTypeTree orig =     toTypeTree pieces@@ -254,43 +279,62 @@             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@(h:_) | isLower h = VarT $ mkName t-nameToType t = ConT $ mkName t+nameToType :: String -> (Type, Name)+nameToType t = (, nm) $ if isTvar t+               then VarT nm+               else ConT nm+    where nm = mkName t -pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)-pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x)-pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652-pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x)+isTvar :: String -> Bool+isTvar (h:_) = isLower h+isTvar _     = False -pieceFromString ('*':'!':x) = Left (False, x)-pieceFromString ('+':'!':x) = Left (False, x)+-- | 'MonadFail' so that an unclosed bracket in a 'Dynamic' piece (via+-- 'dropBracketM') surfaces as an attributed splice error rather than a raw+-- 'error' (the pure 'dropBracket' would otherwise bottom out deep in codegen).+pieceFromString :: MonadFail m => String -> m (Either (CheckOverlap, String) (CheckOverlap, Piece String))+pieceFromString ('#':'!':x) = Right . (False,) . Dynamic <$> dropBracketM x+pieceFromString ('!':'#':x) = Right . (False,) . Dynamic <$> dropBracketM x -- https://github.com/yesodweb/yesod/issues/652+pieceFromString ('#':x) = Right . (True,) . Dynamic <$> dropBracketM x -pieceFromString ('!':'*':x) = Left (False, x)-pieceFromString ('!':'+':x) = Left (False, x)+pieceFromString ('*':'!':x) = pure $ Left (False, x)+pieceFromString ('+':'!':x) = pure $ Left (False, x) -pieceFromString ('*':x) = Left (True, x)-pieceFromString ('+':x) = Left (True, x)+pieceFromString ('!':'*':x) = pure $ Left (False, x)+pieceFromString ('!':'+':x) = pure $ Left (False, x) -pieceFromString ('!':x) = Right $ (False, Static x)-pieceFromString x = Right $ (True, Static x)+pieceFromString ('*':x) = pure $ Left (True, x)+pieceFromString ('+':x) = pure $ Left (True, x) +pieceFromString ('!':x) = pure $ Right (False, Static x)+pieceFromString x = pure $ Right (True, Static x)+ dropBracket :: String -> String dropBracket str@('{':x) = case break (== '}') x of     (s, "}") -> s     _ -> error $ "Unclosed bracket ('{'): " ++ str dropBracket x = x +-- | 'dropBracket' in 'MonadFail': an unclosed @{@ surfaces via 'fail' instead+-- of a raw 'error', so it becomes an attributed compile error at a splice site.+--+-- @since 1.7.0.0+dropBracketM :: MonadFail m => String -> m String+dropBracketM str@('{':x) = case break (== '}') x of+    (s, "}") -> pure s+    _ -> fail $ "Unclosed bracket ('{'): " ++ str+dropBracketM x = pure x+ -- | If this line ends with a backslash, concatenate it together with the next line. -- -- @since 1.6.8 lineContinuations :: String -> [String] -> [String] lineContinuations this [] = [this] lineContinuations this below@(next:rest) = case unsnoc this of-    Just (this', '\\') -> (this'++next):rest+    Just (this', '\\') -> (this' ++ next):rest     _ -> this:below   where unsnoc s = if null s then Nothing else Just (init s, last s)
src/Yesod/Routes/TH.hs view
@@ -1,11 +1,40 @@ module Yesod.Routes.TH     ( module Yesod.Routes.TH.Types       -- * Functions-    , module Yesod.Routes.TH.RenderRoute+    , -- ** RenderRoute+      mkRenderRouteInstanceOpts+    , mkRouteConsOpts+    , shouldCreateResources++    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , roFocusOnNestedRoute+    , roNestedRouteFallthrough+    , setCreateResources+    , setParameterizedSubroute+    , setNestedRouteFallthrough+    , DiscoveryMode(..)+    , discoveryMode     , module Yesod.Routes.TH.ParseRoute     , module Yesod.Routes.TH.RouteAttrs       -- ** Dispatch-    , module Yesod.Routes.TH.Dispatch+    , MkDispatchSettings (..)+    , mkDispatchClause+    , defaultGetHandler+    , SDC(..)+    , mkDispatchInstance+    , mkNestedDispatchInstance+    , mkNestedDispatchInstanceWith+    , NestedTarget (..)+    , mkMDS+    , mkYesodSubDispatch+    , mkYesodSubDispatchWith+    , subTopDispatch     ) where  import Yesod.Routes.TH.Types
src/Yesod/Routes/TH/Dispatch.hs view
@@ -1,202 +1,1054 @@-{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}-module Yesod.Routes.TH.Dispatch-    ( MkDispatchSettings (..)-    , mkDispatchClause-    , defaultGetHandler-    ) where--import Prelude hiding (exp)-import Language.Haskell.TH.Syntax-import Web.PathPieces-import Data.Maybe (catMaybes)-import Control.Monad (forM)-import Data.List (foldl')-import Control.Arrow (second)-import System.Random (randomRIO)-import Yesod.Routes.TH.Types-import Data.Char (toLower)--data MkDispatchSettings b site c = MkDispatchSettings-    { mdsRunHandler :: Q Exp-    , mdsSubDispatcher :: Q Exp-    , mdsGetPathInfo :: Q Exp-    , mdsSetPathInfo :: Q Exp-    , mdsMethod :: Q Exp-    , mds404 :: Q Exp-    , mds405 :: Q Exp-    , mdsGetHandler :: Maybe String -> String -> Q Exp-    , mdsUnwrapper :: Exp -> Q Exp-    }--data SDC = SDC-    { clause404 :: Clause-    , extraParams :: [Exp]-    , extraCons :: [Exp]-    , envExp :: Exp-    , reqExp :: Exp-    }---- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on--- view patterns.------ Since 1.4.0-mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause-mkDispatchClause MkDispatchSettings {..} resources = do-    suffix <- qRunIO $ randomRIO (1000, 9999 :: Int)-    envName <- newName $ "env" ++ show suffix-    reqName <- newName $ "req" ++ show suffix-    helperName <- newName $ "helper" ++ show suffix--    let envE = VarE envName-        reqE = VarE reqName-        helperE = VarE helperName--    clause404' <- mkClause404 envE reqE-    getPathInfo <- mdsGetPathInfo-    let pathInfo = getPathInfo `AppE` reqE--    let sdc = SDC-            { clause404 = clause404'-            , extraParams = []-            , extraCons = []-            , envExp = envE-            , reqExp = reqE-            }-    clauses <- mapM (go sdc) resources--    return $ Clause-        [VarP envName, VarP reqName]-        (NormalB $ helperE `AppE` pathInfo)-        [FunD helperName $ clauses ++ [clause404']]-  where-    handlePiece :: Piece a -> Q (Pat, Maybe Exp)-    handlePiece (Static str) = return (LitP $ StringL str, Nothing)-    handlePiece (Dynamic _) = do-        x <- newName "dyn"-        let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])-        return (pat, Just $ VarE x)--    handlePieces :: [Piece a] -> Q ([Pat], [Exp])-    handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece--    mkCon :: String -> [Exp] -> Exp-    mkCon name = foldl' AppE (ConE $ mkName name)--    mkPathPat :: Pat -> [Pat] -> Pat-    mkPathPat final =-        foldr addPat final-      where-        addPat x y = ConP '(:) [x, y]--    go :: SDC -> ResourceTree a -> Q Clause-    go sdc (ResourceParent name _check pieces children) = do-        (pats, dyns) <- handlePieces pieces-        let sdc' = sdc-                { extraParams = extraParams sdc ++ dyns-                , extraCons = extraCons sdc ++ [mkCon name dyns]-                }-        childClauses <- mapM (go sdc') children--        restName <- newName "rest"-        let restE = VarE restName-            restP = VarP restName--        helperName <- newName $ "helper" ++ name-        let helperE = VarE helperName--        return $ Clause-            [mkPathPat restP pats]-            (NormalB $ helperE `AppE` restE)-            [FunD helperName $ childClauses ++ [clause404 sdc]]-    go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do-        (pats, dyns) <- handlePieces pieces--        (chooseMethod, finalPat) <- handleDispatch dispatch dyns--        return $ Clause-            [mkPathPat finalPat pats]-            (NormalB chooseMethod)-            []-      where-        handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat)-        handleDispatch dispatch' dyns =-            case dispatch' of-                Methods multi methods -> do-                    (finalPat, mfinalE) <--                        case multi of-                            Nothing -> return (ConP '[] [], Nothing)-                            Just _ -> do-                                multiName <- newName "multi"-                                let pat = ViewP (VarE 'fromPathMultiPiece)-                                                (ConP 'Just [VarP multiName])-                                return (pat, Just $ VarE multiName)--                    let dynsMulti =-                            case mfinalE of-                                Nothing -> dyns-                                Just e -> dyns ++ [e]-                        route' = foldl' AppE (ConE (mkName name)) dynsMulti-                        route = foldr AppE route' extraCons-                        jroute = ConE 'Just `AppE` route-                        allDyns = extraParams ++ dynsMulti-                        mkRunExp mmethod = do-                            runHandlerE <- mdsRunHandler-                            handlerE' <- mdsGetHandler mmethod name-                            handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns-                            return $ runHandlerE-                                `AppE` handlerE-                                `AppE` envExp-                                `AppE` jroute-                                `AppE` reqExp--                    func <--                        case methods of-                            [] -> mkRunExp Nothing-                            _ -> do-                                getMethod <- mdsMethod-                                let methodE = getMethod `AppE` reqExp-                                matches <- forM methods $ \method -> do-                                    exp <- mkRunExp (Just method)-                                    return $ Match (LitP $ StringL method) (NormalB exp) []-                                match405 <- do-                                    runHandlerE <- mdsRunHandler-                                    handlerE <- mds405-                                    let exp = runHandlerE-                                            `AppE` handlerE-                                            `AppE` envExp-                                            `AppE` jroute-                                            `AppE` reqExp-                                    return $ Match WildP (NormalB exp) []-                                return $ CaseE methodE $ matches ++ [match405]--                    return (func, finalPat)-                Subsite _ getSub -> do-                    restPath <- newName "restPath"-                    setPathInfoE <- mdsSetPathInfo-                    subDispatcherE <- mdsSubDispatcher-                    runHandlerE <- mdsRunHandler-                    sub <- newName "sub"-                    let allDyns = extraParams ++ dyns-                    sroute <- newName "sroute"-                    let sub2 = LamE [VarP sub]-                            (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns)-                    let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp-                        route' = foldl' AppE (ConE (mkName name)) dyns-                        route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons-                        exp = subDispatcherE-                            `AppE` runHandlerE-                            `AppE` sub2-                            `AppE` route-                            `AppE` envExp-                            `AppE` reqExp'-                    return (exp, VarP restPath)--    mkClause404 envE reqE = do-        handler <- mds404-        runHandler <- mdsRunHandler-        let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE-        return $ Clause [WildP] (NormalB exp) []--defaultGetHandler :: Maybe String -> String -> Q Exp-defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s-defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++module Yesod.Routes.TH.Dispatch+    ( MkDispatchSettings (..)+    , mkDispatchClause+    , defaultGetHandler+    , SDC(..)+    , mkDispatchInstance+    , mkNestedDispatchInstance+    , mkNestedDispatchInstanceWith+    , NestedTarget (..)+    , SameSpliceNestedInstances (..)+    , mkMDS+    , mkYesodSubDispatch+    , mkYesodSubDispatchWith+    , mkYesodSubDispatchWithDelegate+    , subTopDispatch+    , parseYesodName+    ) where++import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)+import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)+import Data.Maybe+import Data.Proxy (Proxy(..))+import Yesod.Routes.TH.RenderRoute+import qualified Network.Wai as W+import Yesod.Core.Content (ToTypedContent (..))+import Language.Haskell.TH hiding (cxt, instanceD)+import Yesod.Core.Types hiding (Body)+import Yesod.Core.Class.Dispatch+import Prelude hiding (exp)+import Yesod.Routes.TH.Internal+import Control.Monad+import Control.Monad.Reader (ReaderT, runReaderT, asks, local, lift)+import Data.List (foldl')+import Yesod.Routes.TH.Types+import Data.Char (toLower)+import Yesod.Core.Internal.Run+import Yesod.Core.Handler+import Yesod.Core.Class.Dispatch.ToParentRoute (ToParentRoute(..))+import Yesod.Core.Class.Yesod (Yesod)++-- | This datatype describes how to create the dispatch clause for a route+-- path.+data MkDispatchSettings b site c = MkDispatchSettings+    { mdsRunHandler :: Q Exp+    , mdsSubDispatcher :: Q Exp+    , mdsGetPathInfo :: Q Exp+    , mdsSetPathInfo :: Q Exp+    , mdsMethod :: Q Exp+    , mds404 :: Q Exp+    , mds405 :: Q Exp+    , mdsGetHandler :: Maybe String -> String -> Q Exp+    , mdsUnwrapper :: Exp -> Q Exp+    , mdsNestedRouteFallthrough :: !Bool+    -- ^ When 'True', fall through if no route matches (except in the final+    -- case). When 'False', return 404 if the current route clause fails to+    -- match.+    --+    -- @since 1.7.0.0+    , mdsNestedTarget :: NestedTarget+    -- ^ Whether this dispatch is for a top-level site or a subsite. Selects the+    -- nested-dispatch class to probe ('nestedTargetClass') and the+    -- nested-dispatch function to delegate to ('nestedTargetFn'):+    -- 'TopLevelNested' uses @YesodDispatchNested@\/@yesodDispatchNested@,+    -- 'SubsiteNested' uses @YesodSubDispatchNested@\/@yesodSubDispatchNested@.+    --+    -- @since 1.7.0.0+    , mdsSameSpliceNestedInstances :: !SameSpliceNestedInstances+    -- ^ Whether the caller emits the matching per-parent nested-dispatch+    -- instances in the same splice as this flat dispatch body; see+    -- 'SameSpliceNestedInstances' for how this affects a parent clause.+    -- 'mkMDS' defaults to 'NoSameSpliceNestedInstances'.+    --+    -- @since 1.7.0.0+    }++data SDC = SDC+    { extraParams :: [Exp]+    , extraCons :: [Exp]+    , envExp :: Exp+    , reqExp :: Exp+    }++-- | Which phase of clause generation we're in, which is the only thing that+-- decides how a matched result is wrapped (see 'wrapForPhase'). At the top level+-- the dispatch result is returned unwrapped; inside a parent's inline children+-- we generate helper clauses whose enclosing parent must tell a match from a+-- fall-through miss, so the result is wrapped in 'Just'. Generation starts at+-- 'TopLevelPhase' and flips to 'NestedPhase' on the first descent (and never+-- back), so the two phases are a single 'local'.+data DispatchPhase = TopLevelPhase | NestedPhase++-- | How a matched result is wrapped in a given phase. See 'DispatchPhase'.+wrapForPhase :: DispatchPhase -> Exp -> Exp+wrapForPhase TopLevelPhase = id+wrapForPhase NestedPhase = \e -> ConE 'Just `AppE` e++-- | The reader environment threaded through 'mkDispatchClause's clause+-- generator. 'envSdc' is the accumulated dispatch context (extended via 'local'+-- as we descend into a parent's children); 'envPhase' selects how a matched+-- result is wrapped.+data Env = Env+    { envSdc :: SDC+    , envPhase :: DispatchPhase+    }++-- | The monad 'mkDispatchClause's clause generator runs in: 'Q' carrying an+-- 'Env' read through 'MonadReader'. Every helper that needs the dispatch+-- context or the result wrapper takes them from the environment ('asks' /+-- 'local') rather than as arguments; 'liftQ' lifts the concrete-'Q' primitives.+type DispatchM = ReaderT Env Q++-- | Whether nested-route dispatch is being generated for a top-level site or+-- for a subsite. This is the single bit that selects the whole top-vs-subsite+-- plumbing: the dispatch class to probe and the function to delegate to (used+-- by 'MkDispatchSettings' via 'mdsNestedTarget'), and the runner function,+-- dispatch function\/class, and subsite-environment construction used when+-- generating nested-dispatch instances. All of those follow from this enum via+-- the @nestedTarget*@ derivation functions below.+--+-- @since 1.7.0.0+data NestedTarget+    = TopLevelNested+    -- ^ A top-level site: @YesodDispatchNested@\/@yesodDispatchNested@, run via+    -- @yesodRunner@, constructing 'YesodSubRunnerEnv' directly.+    | SubsiteNested+    -- ^ A subsite: @YesodSubDispatchNested@\/@yesodSubDispatchNested@, run via+    -- @subHelper@, composing through the outer 'YesodSubRunnerEnv' (like+    -- 'subTopDispatch').+    deriving (Eq, Show)++-- | Whether the splice emitting a flat dispatch body also generates the+-- matching per-parent nested-dispatch instances (@YesodDispatchNested@ \/+-- @YesodSubDispatchNested@) in the same declaration group.+--+-- @since 1.7.0.0+data SameSpliceNestedInstances+    = GeneratesNestedInstances+    -- ^ The caller emits the per-parent nested instances alongside the flat+    -- dispatch, so a parent clause /delegates/ to its instance even though the+    -- instance does not exist at probe time — GHC resolves it once the whole+    -- declaration group is spliced. This avoids inlining each nested leaf's+    -- dispatch into the flat body /and/ re-emitting it in the per-parent+    -- instance (see 'mkTopLevelDispatchInstance').+    | NoSameSpliceNestedInstances+    -- ^ Only the flat dispatch is emitted. A parent delegates only when its+    -- nested instance already exists (the cross-module split case) and inlines+    -- otherwise — required for standalone entry points like+    -- 'mkYesodSubDispatch', where delegating would reference a missing+    -- instance.+    deriving (Eq, Show)++-- | The nested-dispatch class to probe\/emit for a target:+-- @''YesodDispatchNested@ for top-level, @''YesodSubDispatchNested@ for subsites.+nestedTargetClass :: NestedTarget -> Name+nestedTargetClass TopLevelNested = ''YesodDispatchNested+nestedTargetClass SubsiteNested  = ''YesodSubDispatchNested++-- | The nested-dispatch function to delegate to\/emit for a target:+-- @'yesodDispatchNested@ for top-level, @'yesodSubDispatchNested@ for subsites.+nestedTargetFn :: NestedTarget -> Name+nestedTargetFn TopLevelNested = 'yesodDispatchNested+nestedTargetFn SubsiteNested  = 'yesodSubDispatchNested++-- | The runner function used inside generated nested-dispatch clauses:+-- @'yesodRunner@ for top-level, @'subHelper@ for subsites.+nestedTargetRunner :: NestedTarget -> Name+nestedTargetRunner TopLevelNested = 'yesodRunner+nestedTargetRunner SubsiteNested  = 'subHelper++-- | The 'ArityCallSite' for arity-mismatch error messages: a top-level site is+-- reached through @mkYesod@, a subsite through @mkYesodSubDispatchInstance@.+nestedTargetCallSite :: NestedTarget -> ArityCallSite+nestedTargetCallSite TopLevelNested = TopLevelCall+nestedTargetCallSite SubsiteNested  = SubsiteCall++-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on+-- view patterns.+--+-- The function returns the dispatch 'Clause' along with a @['String']@ of the+-- names of nested route types that require a delegation instance to be+-- generated. For 'YesodDispatch', those are 'YesodDispatchNested' instances; for+-- the subsite case, 'YesodSubDispatchNested'.+--+-- @since 1.7.0.0 — the leading @[Name]@\/@[Exp]@ parameters were dropped and the+-- result type changed from @Clause@ to @Q ([String], Clause)@.+mkDispatchClause :: forall a b site c. TyArgs -> MkDispatchSettings b site c -> [ResourceTree a] -> Q ([String], Clause)+mkDispatchClause tyargs MkDispatchSettings {..} resources = do+    envName <- newName "env"+    reqName <- newName "req"+    helperName <- newName "dispatchHelper"++    let envE = VarE envName+        reqE = VarE reqName+        helperE = VarE helperName++    clause404' <- mkClause404 envE reqE+    getPathInfo <- mdsGetPathInfo+    let pathInfo = getPathInfo `AppE` reqE++    let sdc = SDC+            { extraParams = []+            , extraCons = []+            , envExp = envE+            , reqExp = reqE+            }+    -- Generate the dispatch clauses. 'go' runs in @'ReaderT' 'Env' Q@: the+    -- top-level call starts at @envPhase = TopLevelPhase@ so the top-level+    -- resources produce the final (unwrapped) dispatch result and report which+    -- parents need a nested-dispatch instance generated. Descending into a+    -- parent's inline children flips @envPhase@ to 'NestedPhase' (via 'local'),+    -- so children are 'Just'-wrapped helper clauses the enclosing parent can+    -- fall through on; their reported names are dropped (only top-level parents+    -- matter).+    let topEnv = Env { envSdc = sdc, envPhase = TopLevelPhase }+    (childNames, clauses) <- mconcat <$> runReaderT (mapM go resources) topEnv++    pure+        ( childNames+        , Clause+            [VarP envName, VarP reqName]+            (NormalB $ helperE `AppE` pathInfo)+            [FunD helperName $ clauses ++ [clause404']]+        )+  where+    -- Lift a concrete-'Q' action (the TH primitives and this package's own+    -- @Q@-typed helpers) into 'DispatchM'.+    liftQ :: Q x -> DispatchM x+    liftQ = lift++    -- The current phase's result wrapper (see 'wrapForPhase').+    askWrap :: DispatchM (Exp -> Exp)+    askWrap = asks (wrapForPhase . envPhase)++    -- Run an action in the scope of a parent's inline children: extend the+    -- accumulated dynamics and parent constructors with this parent's, and flip+    -- to 'NestedPhase'. This single 'local' — entered once at the top→nested+    -- boundary and never undone — is the entire top-vs-nested phase distinction.+    withChildScope :: [Exp] -> Exp -> DispatchM r -> DispatchM r+    withChildScope dyns constr = local $ \e ->+        let sdc = envSdc e+        in e { envSdc = sdc+                 { extraParams = extraParams sdc ++ dyns+                 , extraCons = extraCons sdc ++ [constr]+                 }+             , envPhase = NestedPhase+             }++    -- | Generate the dispatch clauses for a resource tree node, plus the+    -- @['String']@ of parents that need a nested-dispatch instance generated.+    -- Names are reported for every parent here, but only the top-level call+    -- keeps them; the parent arm drops its children's names (the deeper+    -- instances are generated by a separate recursion in+    -- 'mkNestedDispatchInstanceWith').+    go :: ResourceTree a -> DispatchM ([String], [Clause])+    go (ResourceParent name _check _attrs pieces children) = do+        -- Delegate to the child's nested-dispatch instance when one already+        -- exists (the configured class: YesodDispatchNested for top-level,+        -- YesodSubDispatchNested for subsites). This is what makes splitting+        -- a parent's nested routes across modules work. When no such instance+        -- exists — the ordinary single-module case — the check fails and we+        -- inline the children below, so this stays backwards compatible.+        -- 'nestedInstanceExists' is the shared probe: it resolves the name once+        -- and saturates by the child's own reified arity, so it never aborts+        -- the splice (see its haddock).+        instanceExists <-+            liftQ (nestedInstanceExists (nestedTargetClass mdsNestedTarget) =<< resolveRouteCon name)++        -- Delegate to the nested-dispatch instance either when one already+        -- exists (cross-module split) or when the caller will generate it in+        -- this same splice ('mdsSameSpliceNestedInstances'). In the latter case+        -- the instance does not exist at probe time, but GHC resolves it after+        -- the whole declaration group is spliced — so we avoid inlining every+        -- nested leaf's dispatch logic here only to re-emit it in the parent's+        -- 'YesodDispatchNested' instance. We still report the name below so that+        -- instance actually gets generated.+        let delegate =+                instanceExists || mdsSameSpliceNestedInstances == GeneratesNestedInstances++        (pats, dyns) <- liftQ $ handlePiecesM pieces+        restName <- liftQ $ newName "_rest"+        helperName <- liftQ $ newName ("helper" ++ name)+        let helperCall = VarE helperName `AppE` VarE restName+            constr = applyConPieces name dyns++        helperClauses <-+            if delegate+                then do+                    expr <- delegateToNestedInstance name dyns+                    pure [Clause [VarP restName] (NormalB expr) []]+                else do+                    -- Inline dispatch: descend into the children with the+                    -- extended scope and 'Just' wrapping; their reported names+                    -- are dropped (only top-level parents matter).+                    childClauses <-+                        concatMap snd <$> withChildScope dyns constr (mapM go children)+                    pure $ childClauses ++ [Clause [WildP] (NormalB (ConE 'Nothing)) []]++        body <- parentBody helperCall++        -- Report this parent as needing a nested-dispatch instance whenever one+        -- does not already exist — both when we inlined and when we delegated to+        -- a yet-to-be-generated same-splice instance+        -- ('mdsSameSpliceNestedInstances').+        -- Whether the caller acts on this (i.e. actually generates the instance)+        -- is the caller's decision — see 'mkDispatchInstance'.+        pure+            ( [name | not instanceExists]+            , [ Clause+                [mkPathPat (EndRest restName) pats]+                body+                [FunD helperName helperClauses] ]+            )++    go (ResourceLeaf (Resource name pieces dispatch _ _check)) = do+        (pats, dyns) <- liftQ $ handlePiecesM pieces+        (chooseMethod, finalPat) <- handleDispatch name dispatch dyns+        wrap <- askWrap+        let clauseBody = NormalB (wrap chooseMethod)+        pure ([], [Clause [mkPathPat finalPat pats] clauseBody []])++    -- | Delegate body for a parent that already has a nested-dispatch instance:+    -- call the configured nested-dispatch function, passing this route's+    -- dynamics — plus the accumulated parent dynamics from the environment — as+    -- ParentArgs.+    delegateToNestedInstance :: String -> [Exp] -> DispatchM Exp+    delegateToNestedInstance name dyns = do+        sdc <- asks envSdc+        let thisRouteParentArgs = extraParams sdc ++ dyns+        liftQ (nestedDispatchCall (nestedTargetFn mdsNestedTarget) name dyns tyargs sdc thisRouteParentArgs)++    -- | The body of a parent dispatch clause. @helperCall@ runs the parent's+    -- inline helper on the remaining path; per the fallthrough flag we either+    -- fall through on a 'Nothing' (pattern guard) or commit to a 404. The+    -- matched result is run through the current phase's wrapper.+    parentBody :: Exp -> DispatchM Body+    parentBody helperCall = do+        wrap <- askWrap+        if mdsNestedRouteFallthrough+            then liftQ $ mkGuardedBody helperCall (\match' -> pure (wrap (VarE match')))+            else do+                sdc <- asks envSdc+                liftQ $ do+                    matchName <- newName "match"+                    baseNotFoundExp <-+                        [| $(mdsRunHandler) $(mds404) $(pure (envExp sdc)) Nothing $(pure (reqExp sdc)) |]+                    pure $ NormalB $ CaseE helperCall+                        [ Match (conPCompat 'Just [VarP matchName]) (NormalB (wrap (VarE matchName))) []+                        , Match (conPCompat 'Nothing []) (NormalB (wrap baseNotFoundExp)) []+                        ]++    -- | Build the chosen-method expression and final path tail for a leaf,+    -- reading the dispatch context ('extraParams' / 'extraCons' / 'envExp' /+    -- 'reqExp') from the environment.+    handleDispatch :: String -> Dispatch a -> [Exp] -> DispatchM (Exp, PathTail)+    handleDispatch name dispatch' dyns = do+        SDC {..} <- asks envSdc+        liftQ $ case dispatch' of+                Methods multi methods -> do+                    (finalPat, mfinalE) <-+                        case multi of+                            Nothing -> return (EndExact, Nothing)+                            Just _ -> do+                                multiName <- newName "multi"+                                return (EndMulti multiName, Just $ VarE multiName)++                    let dynsMulti =+                            case mfinalE of+                                Nothing -> dyns+                                Just e -> dyns ++ [e]+                        thisRoute = applyConPieces name dynsMulti+                        fullRoute = foldr AppE thisRoute extraCons+                        jroute = ConE 'Just `AppE` fullRoute+                        allDyns = extraParams ++ dynsMulti+                        mkRunExp mmethod = do+                            runHandlerE <- mdsRunHandler+                            handlerE' <- mdsGetHandler mmethod name+                            handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns+                            return $ runHandlerE+                                `AppE` handlerE+                                `AppE` envExp+                                `AppE` jroute+                                `AppE` reqExp++                    func <-+                        case methods of+                            [] -> mkRunExp Nothing+                            _ -> do+                                getMethod <- mdsMethod+                                let methodE = getMethod `AppE` reqExp+                                matches <- forM methods $ \method -> do+                                    exp <- mkRunExp (Just method)+                                    return $ Match (LitP $ StringL method) (NormalB exp) []+                                match405 <- do+                                    runHandlerE <- mdsRunHandler+                                    handlerE <- mds405+                                    let exp = runHandlerE+                                            `AppE` handlerE+                                            `AppE` envExp+                                            `AppE` jroute+                                            `AppE` reqExp+                                    return $ Match WildP (NormalB exp) []+                                return $ CaseE methodE $ matches ++ [match405]++                    return (func, finalPat)++                Subsite _ getSub -> do+                    restPath <- newName "restPath"+                    let allDyns = extraParams ++ dyns+                    sub2 <- mkLambda "sub" $ \sub ->+                        pure $ foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns+                    routeBuilder <- mkLambda "sroute" $ \sroute ->+                        pure $ let thisRoute = applyConPieces name dyns+                               in foldr AppE (AppE thisRoute $ VarE sroute) extraCons+                    exp <-+                        [| $(mdsSubDispatcher)+                            $(mdsRunHandler)+                            $(pure sub2)+                            $(pure routeBuilder)+                            $(pure envExp)+                            ($(mdsSetPathInfo) $(varE restPath) $(pure reqExp)) |]+                    return (exp, EndRest restPath)++    -- The dispatch helper produced by 'mkDispatchClause' is always a terminal+    -- authority (the top-level / subsite entry point), so a final miss commits+    -- to a 404 here. Inline nested helpers built by 'go' under 'withChildScope'+    -- bake their own @Nothing@ fallback at their call site instead.+    mkClause404 envE reqE = do+        exp <- [| $(mdsRunHandler) $(mds404) $(pure envE) Nothing $(pure reqE) |]+        return $ Clause [WildP] (NormalB exp) []++-- | This function generates code to call the nested dispatch function+-- (either 'yesodDispatchNested' or 'yesodSubDispatchNested').+nestedDispatchCall+    :: Name+    -- ^ The dispatch function to call (e.g. 'yesodDispatchNested' or 'yesodSubDispatchNested')+    -> String+    -- ^ The name of the nested route (e.g., "FirstFooR")+    -> [Exp]+    -- ^ The dynamic arguments for this route constructor+    -> TyArgs+    -- ^ Type arguments for parameterized routes+    -> SDC+    -- ^ The accumulated 'SDC'.+    -> [Exp]+    -- ^ The parent dynamic bound variables (for passing as ParentArgs).+    -> Q Exp+nestedDispatchCall dispatchFn routeName routeDyns tyargs sdc parentDyns = do+    routeType <- appliedRouteTypeNamed routeName tyargs+    let wrapper = foldr composeE (applyConPieces routeName routeDyns) (extraCons sdc)+    [| $(varE dispatchFn)+        (Proxy :: Proxy $(pure routeType))+        $(pure $ parentArgsExprFromExps parentDyns)+        $(pure wrapper)+        $(pure $ envExp sdc)+        $(pure $ reqExp sdc)+     |]++-- | Given an 'Exp' which should result in a @'Maybe' a@, does:+--+-- @+--   | Just a <- exp = mkRhs a+-- @+--+mkGuardedBody+    :: Exp+    -- ^ The expression to match Just with+    -> (Name -> Q Exp)+    -- ^ The function to take a 'Name' and create the right hand value on+    -- successful match.+    -> Q Body+mkGuardedBody exp mkRhs = do+    matchName <- newName "match"+    result <- mkRhs matchName+    let patGuard =+            PatG [BindS (conPCompat 'Just [VarP matchName]) exp]+    pure $ GuardedB [(patGuard, result)]++defaultGetHandler :: Maybe String -> String -> Q Exp+defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s+defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s++-- | If the generation of @'YesodDispatch'@ instance require finer+-- control of the types, contexts etc. using this combinator. You will+-- hardly need this generality. However, in certain situations, like+-- when writing library/plugin for yesod, this combinator becomes+-- handy.+mkDispatchInstance+    :: RouteOpts+    -> Type+    -- ^ The master site type+    -> Cxt+    -- ^ Context of the instance+    -> TyArgs+    -- ^ type arguments to constructors+    -> (Exp -> Q Exp)+    -- ^ Unwrap handler+    -> [ResourceTree Type]+    -- ^ The resource+    -> DecsQ+mkDispatchInstance routeOpts master cxt tyargs unwrapper res =+    -- Branch on the focus target via the accessor rather than a constructor+    -- pattern, so 'RouteOpts' can stay abstract (its constructor is not+    -- exported). 'Just target' focuses a single nested route for+    -- module-splitting; 'Nothing' generates the full top-level instance.+    case roFocusOnNestedRoute routeOpts of+        Just target ->+            mkNestedDispatchInstance routeOpts target master cxt tyargs unwrapper res+        Nothing ->+            mkTopLevelDispatchInstance routeOpts master cxt tyargs unwrapper res++mkTopLevelDispatchInstance+    :: RouteOpts+    -> Type+    -> Cxt+    -> TyArgs+    -> (Exp -> Q Exp)+    -> [ResourceTree Type]+    -> DecsQ+mkTopLevelDispatchInstance routeOpts master cxt tyargs unwrapper res = do+    let mds =+            mkMDS+                unwrapper+                [|yesodRunner|]+                [|\parentRunner getSub toParent env -> yesodSubDispatch+                    YesodSubRunnerEnv+                    { ysreParentRunner = parentRunner+                    , ysreGetSub = getSub+                    , ysreToParentRoute = toParent+                    , ysreParentEnv = env+                    }+                |]+        -- Under nested discovery this instance also emits a+        -- 'YesodDispatchNested' instance per top-level parent (see+        -- 'childNamesToGenerate'). When it does, the flat @yesodDispatch@ clause+        -- can /delegate/ each parent to that same-splice instance rather than+        -- inlining the whole subtree's dispatch logic (which the nested instance+        -- would then re-emit). Under 'InlineCompat' no nested instances are+        -- generated, so the flat clause must inline as before.+        usesNestedDiscovery =+            case discoveryMode routeOpts tyargs of+                NestedDiscovery -> True+                InlineCompat    -> False+        mdsWithNestedDispatch = mds+            { mdsNestedRouteFallthrough = roNestedRouteFallthrough routeOpts+            , mdsSameSpliceNestedInstances =+                if usesNestedDiscovery+                    then GeneratesNestedInstances+                    else NoSameSpliceNestedInstances+            }+    (childNames, clause') <- mkDispatchClause tyargs mdsWithNestedDispatch res+    let thisDispatch = FunD 'yesodDispatch [clause']+        -- Only generate 'YesodDispatchNested' instances for children when this+        -- site uses nested discovery. A parameterized site that has not opted+        -- in keeps unparameterized subroute datatypes (see 'discoveryMode' in+        -- RenderRoute), so generating nested instances — which would reference+        -- the parameterized form — must be suppressed to stay consistent.+        childNamesToGenerate =+            if usesNestedDiscovery then childNames else []+    childInstances <-+        fmap mconcat $ forM childNamesToGenerate $ \name -> do+            mkNestedDispatchInstance routeOpts name master cxt tyargs unwrapper res+    return (instanceD cxt yDispatch [thisDispatch] : childInstances)+  where+    yDispatch = ConT ''YesodDispatch `AppT` master++-- | Generate the top-level @YesodDispatchNested@ instance (and the+-- @UrlToDispatch@\/@RedirectUrl@ instances for fragments with no dynamic parent+-- pieces) for a nested route target. A thin wrapper over+-- 'mkNestedDispatchInstanceWith' with the top-level config and the master site.+--+-- @since 1.7.0.0+mkNestedDispatchInstance+    :: RouteOpts+    -> String+    -> Type+    -> Cxt+    -> TyArgs -- ^ tyargs+    -> (Exp -> Q Exp)+    -> [ResourceTree Type]+    -> Q [Dec]+mkNestedDispatchInstance routeOpts target master cxt tyargs unwrapper res =+    mkNestedDispatchInstanceWith TopLevelNested (Just master)+        routeOpts target cxt tyargs unwrapper res++-- | The shared body of the top-level ('mkNestedDispatchInstance') and subsite+-- (@mkNestedSubDispatchInstance@, in "Yesod.Core.Internal.TH") nested-dispatch+-- instance generators. Both+-- find the target, build the parent-dynamics pattern, generate the dispatch+-- clauses via 'genNestedDispatchClauses', emit one+-- 'nestedTargetClass'\/'nestedTargetFn' instance, and recurse into nested+-- children. They differ only in the 'NestedTarget' (which selects the+-- dispatch function\/class, runner, and subsite-env construction) and whether a+-- master site is in play: a @'Just' master@ marks the top-level case and additionally emits+-- the @UrlToDispatch@\/@RedirectUrl@ instances, which the subsite case+-- ('Nothing') never produces.+mkNestedDispatchInstanceWith+    :: NestedTarget+    -> Maybe Type            -- ^ @Just master@ ⇒ top-level (also emit UrlToDispatch\/RedirectUrl); @Nothing@ ⇒ subsite+    -> RouteOpts+    -> String+    -> Cxt+    -> TyArgs+    -> (Exp -> Q Exp)+    -> [ResourceTree Type]+    -> Q [Dec]+mkNestedDispatchInstanceWith nestedTarget mmaster routeOpts target cxt tyargs unwrapper res = do+    -- Resolve the target subtree from the root exactly once. The recursion into+    -- nested children below threads the already-resolved @(prePieces, subres)@+    -- straight through ('go'), rather than re-passing the full root and walking+    -- it from scratch for every descendant (which was O(nodes × depth)).+    case findNestedRoute target res of+        Nothing ->+            fail $ "Target '" ++ target ++ "' was not found in resources."+        Just (prePieces, subres) ->+            go target prePieces subres+  where+   go curTarget prePieces subres = do+    -- The parent's static depth and how many dynamic pieces it consumes (only+    -- the count matters below, for the parent-dynamics pattern and the+    -- no-dynamics UrlToDispatch case).+    let parentDepth = length prePieces+        preDyns = [() | Dynamic _ <- prePieces]+        targetT = applyTyArgs (ConT (mkName curTarget)) tyargs++    -- UrlToDispatch/RedirectUrl is a top-level-only convenience and only+    -- possible when ParentArgs ~ () (no dynamic parent pieces).+    urlToDispatchInstances <- case (mmaster, preDyns) of+        (Just master, []) ->+            mkUrlToDispatchRedirectInstances cxt curTarget targetT master+        _ ->+            pure []++    -- Generate the parent dynamic argument variables once, and derive the+    -- binding pattern from them. The clause-generator is handed the @['Name']@+    -- directly (it used to re-decode them out of the pattern).+    parentDynVars <- forM preDyns $ \_ -> newName "parentDyn"+    let parentDynsP = parentArgsPat parentDynVars++    -- Generate names for the instance parameters+    toParentN <- newName "toParentRoute"+    envN <- newName "env"+    reqN <- newName "req"++    -- Generate dispatch clauses for each child resource+    clauses <- genNestedDispatchClauses+        nestedTarget+        routeOpts+        parentDynVars+        (VarE toParentN)+        (VarE envN)+        (VarE reqN)+        unwrapper+        tyargs+        subres++    dropExp <- [| drop parentDepth (W.pathInfo $(varE reqN)) |]+    let dispatchNestedT = ConT (nestedTargetClass nestedTarget) `AppT` targetT+        thisDispatch = FunD (nestedTargetFn nestedTarget)+            [Clause+                [WildP, parentDynsP, VarP toParentN, VarP envN, VarP reqN]+                (NormalB $ CaseE dropExp clauses)+                []+            ]++    childInstances <-+        fmap mconcat $ forM subres $ \childRes -> do+            case childRes of+                ResourceParent name _ _ childPieces grandchildren -> do+                    rc <- resolveRouteCon name+                    instanceExists <- nestedInstanceExists (nestedTargetClass nestedTarget) rc+                    if instanceExists+                        then pure []+                        else do+                            -- Run the same arity guard the top-level+                            -- 'mkYesodSubDispatchInstance' applies, so a+                            -- 2nd-level-or-deeper nested datatype whose+                            -- parameter count doesn't match the (sub)site's+                            -- type arguments fails with the actionable message+                            -- rather than a cryptic kind error from generated+                            -- code. A no-op for the monomorphic (0-arity) case.+                            assertNestedSubArity+                                (nestedTargetCallSite nestedTarget)+                                (SubsiteName curTarget)+                                (SubsiteArity (tyArgsArity tyargs))+                                rc+                            -- Recurse on the already-resolved subtree: this+                            -- child's accumulated prefix is the parent's plus+                            -- this child's own pieces.+                            go name (prePieces <> childPieces) grandchildren+                _ -> pure []++    return+        ( instanceD cxt dispatchNestedT+            [ thisDispatch+            ]+        : childInstances <> urlToDispatchInstances+        )++-- | The top-level-only @UrlToDispatch@ + @RedirectUrl@ instances for a nested+-- route fragment whose @ParentArgs ~ ()@ (no dynamic parent pieces), letting+-- the fragment's constructor be used directly in @setUrl@\/@redirect@ without+-- the @WithParentArgs@ wrapper. Subsite nested dispatch emits none of these.+mkUrlToDispatchRedirectInstances+    :: Cxt+    -> String  -- ^ target route name (for the in-scope ToParentRoute check)+    -> Type    -- ^ the applied target route type+    -> Type    -- ^ the master site type+    -> Q [Dec]+mkUrlToDispatchRedirectInstances cxt target targetT master = do+    urlToDispatchT <- [t| UrlToDispatch $(pure targetT) $(pure master) |]+    urlToDispatchFn <- [e| toWaiAppYreNested (Proxy :: Proxy $(pure targetT)) () |]+    mYesodConstraint <- do+        hasYesodInstance <- isInstance ''Yesod [master]+        if hasYesodInstance+            then pure []+            else do+                yesodContext <- [t| Yesod $(pure master) |]+                pure [yesodContext]+    mToParentRouteConstraint <- do+        mtypeName <- lookupTypeName target+        parentRouteCxt <- [t| ToParentRoute $(pure targetT) |]+        case mtypeName of+            Nothing -> do+                -- must be generating it still. assume we don't+                -- have the instance in scope.+                pure [parentRouteCxt]+            Just _ -> do+                -- type is around, let's make sure it's not+                -- redundant?+                hasToParentRouteInstance <- isInstance ''ToParentRoute [targetT]+                if hasToParentRouteInstance+                    then pure []+                    else do+                        pure [parentRouteCxt]+    redirectT <- [t| RedirectUrl $(pure master) $(pure targetT) |]+    redirectUrlFn <- [e| toTextUrl . WithParentArgs () |]+    pure+        [ instanceD (cxt <> mYesodConstraint <> mToParentRouteConstraint) urlToDispatchT+            [ FunD 'urlToDispatch+                [ Clause [ WildP ] (NormalB urlToDispatchFn) []+                ]+            ]+        -- OVERLAPPABLE so a strictly more specific hand-written instance (e.g.+        -- one carrying type variables, as for a parameterized site) takes+        -- precedence over this generated convenience instance. Note that a+        -- hand-written instance with an identical fully-concrete head still+        -- collides as a duplicate, regardless of this pragma.+        , InstanceD (Just Overlappable) (cxt <> mToParentRouteConstraint) redirectT+            [ FunD 'toTextUrl+                [ Clause [ ] (NormalB redirectUrlFn) [] ]+            ]+        ]+++-- | Generate dispatch clauses for nested dispatch instances.+-- Parameterized by 'NestedTarget' to support both+-- 'YesodDispatchNested' (top-level) and 'YesodSubDispatchNested' (subsite).+genNestedDispatchClauses+    :: NestedTarget+    -> RouteOpts+    -> [Name] -- ^ parent dynamic arg variables+    -> Exp -- ^ toParentRoute expression+    -> Exp -- ^ yre expression (YesodRunnerEnv or YesodSubRunnerEnv)+    -> Exp -- ^ req expression+    -> (Exp -> Q Exp) -- ^ unwrapper+    -> TyArgs -- ^ type arguments for parameterized routes+    -> [ResourceTree Type]+    -> Q [Match]+genNestedDispatchClauses nestedTarget routeOpts parentDynVars toParentE yreE reqE unwrapper tyargs resources = do+    resourceClauses <- traverse genClauseForResource resources++    -- Terminal-miss clause: a nested dispatch instance ALWAYS returns 'Nothing'+    -- when no clause matches the remaining path, regardless of this module's+    -- fallthrough flag. 'yesodDispatchNested'/'yesodSubDispatchNested' are+    -- documented to return 'Nothing' on a miss so that the *caller* (the+    -- delegating parent clause, or the top-level/subsite terminal authority)+    -- decides whether the miss commits to a 404 or falls through to a sibling.+    -- Baking a 404 in here when fallthrough is disabled would let a split-out+    -- child silently override a fallthrough-wanting parent compiled in another+    -- module. The commit semantics of @fallthrough = False@ instead live at the+    -- delegating clauses (the 'ResourceParent' arm below and the inline parent+    -- body in 'mkDispatchClause') and at the terminal authorities.+    let fallbackClause = Match WildP (NormalB (ConE 'Nothing)) []++    return $ concat resourceClauses ++ [fallbackClause]+  where+    genClauseForResource :: ResourceTree Type -> Q [Match]+    genClauseForResource (ResourceLeaf (Resource name pieces dispatch _ _check)) = do+        (pats, dynVars) <- handlePiecesNames pieces+        let routeCon = applyConPieces name (map VarE dynVars)+            allDynVars = parentDynVars ++ dynVars++        case dispatch of+            Methods mmulti methods -> do+                -- Mirror the inline path (see 'handleDispatch' in+                -- 'mkDispatchClause'): a trailing multipiece binds a fresh+                -- @multi@ via 'EndMulti', and that value must be appended both+                -- to the route constructor's arguments and to the handler's+                -- arguments. Hardcoding 'EndExact' here would 404 any non-empty+                -- tail and build the constructor one argument short.+                (finalPat, mMultiE) <- case mmulti of+                    Nothing -> pure (EndExact, Nothing)+                    Just _ -> do+                        multiName <- newName "multi"+                        pure (EndMulti multiName, Just (VarE multiName))+                let dynExpsMulti = case mMultiE of+                        Nothing -> map VarE dynVars+                        Just e  -> map VarE dynVars ++ [e]+                    routeExp = toParentE `AppE` applyConPieces name dynExpsMulti+                    allDynExps = map VarE parentDynVars ++ dynExpsMulti+                handlerExp <- genHandlerCase name methods allDynExps+                body <-+                    [| Just ($(varE (nestedTargetRunner nestedTarget))+                                $(pure handlerExp)+                                $(pure yreE)+                                (Just $(pure routeExp))+                                $(pure reqE)) |]+                return [Match (mkPathPat finalPat pats) (NormalB body) []]++            Subsite _ getSub -> do+                restPath <- newName "restPath"+                sub2 <- mkLambda "sub" $ \sub ->+                    pure $ foldl' AppE (VarE (mkName getSub) `AppE` VarE sub) (map VarE allDynVars)+                routeLam <- mkLambda "sroute" $ \srouteN ->+                    [e| $(pure toParentE) ( $(pure routeCon) $(varE srouteN)) |]+                let reqExp' = RecUpdE reqE [('W.pathInfo, VarE restPath)]+                body <- case nestedTarget of+                    TopLevelNested ->+                        -- Top-level: construct YesodSubRunnerEnv directly+                        [| Just (yesodSubDispatch+                            YesodSubRunnerEnv+                                { ysreParentRunner = yesodRunner+                                , ysreGetSub = $(pure sub2)+                                , ysreToParentRoute = $(pure routeLam)+                                , ysreParentEnv = $(pure yreE)+                                }+                            $(pure reqExp')) |]+                    SubsiteNested ->+                        -- Subsite: compose through the outer YesodSubRunnerEnv+                        [| Just (yesodSubDispatch+                            YesodSubRunnerEnv+                                { ysreParentRunner = ysreParentRunner $(pure yreE)+                                , ysreGetSub = $(pure sub2) . ysreGetSub $(pure yreE)+                                , ysreToParentRoute = ysreToParentRoute $(pure yreE) . $(pure routeLam)+                                , ysreParentEnv = ysreParentEnv $(pure yreE)+                                }+                            $(pure reqExp')) |]+                return [Match (mkPathPat (EndRest restPath) pats) (NormalB body) []]++    genClauseForResource (ResourceParent name _check _attrs pieces _children) = do+        (pats, dynVars) <- handlePiecesNames pieces++        -- Build the parent args tuple for the nested call+        let allDynVars = parentDynVars ++ dynVars+            parentArgsExp = parentArgsExpr allDynVars+            routeConWrapper = applyConPieces name (map VarE dynVars)++        routeType <- appliedRouteTypeNamed name tyargs++        resultName <- newName "k"++        nestedCall <-+            [| $(varE (nestedTargetFn nestedTarget))+                (Proxy :: Proxy $(pure routeType))+                $(pure parentArgsExp)+                ($(pure toParentE) . $(pure routeConWrapper))+                $(pure yreE)+                $(pure reqE) |]++        if roNestedRouteFallthrough routeOpts+            then do+                -- Fallthrough enabled: pattern-guard on a 'Just' result, so a+                -- 'Nothing' from the delegated child lets dispatch fall through+                -- to sibling clauses (and ultimately the 'Nothing' fallback).+                let patGuard = BindS (conPCompat 'Just [VarP resultName]) nestedCall+                    guardedBody = GuardedB [(PatG [patGuard], ConE 'Just `AppE` VarE resultName)]+                return [Match (mkPathPat EndWild pats) guardedBody []]+            else do+                -- Fallthrough disabled: once this parent's path prefix matches we+                -- commit to its subtree. If the delegated child dispatch returns+                -- 'Nothing', convert it to a 404 handler call rather than letting+                -- the 'Nothing' propagate (which, under an outer fallthrough+                -- caller, would let it fall through to siblings). This mirrors the+                -- inline no-fallthrough path's @Nothing -> Just 404@ shape.+                committedBody <-+                    [| Just (fromMaybe+                        ($(varE (nestedTargetRunner nestedTarget))+                            (void notFound) $(pure yreE) Nothing $(pure reqE))+                        $(pure nestedCall)) |]+                return [Match (mkPathPat EndWild pats) (NormalB committedBody) []]++    genHandlerCase :: String -> [String] -> [Exp] -> Q Exp+    genHandlerCase name methods allDynExps = do+        let handlerExpFor mmethod = do+                handlerName <- defaultGetHandler mmethod name+                unwrapper $ foldl' AppE handlerName allDynExps++        if null methods+            then do+                -- No specific methods, just call handler+                handlerE <- handlerExpFor Nothing+                [| fmap toTypedContent $(pure handlerE) |]+            else do+                -- Generate method case+                -- Wrap each handler with fmap toTypedContent so all branches have the same type+                methodMatches <- forM methods $ \method -> do+                    handlerE <- handlerExpFor (Just method)+                    wrappedHandler <- [| fmap toTypedContent $(pure handlerE) |]+                    return $ Match (LitP $ StringL method) (NormalB wrappedHandler) []++                badMethodHandler <- unwrapper (VarE 'badMethod)+                let badMethodMatch = Match WildP (NormalB badMethodHandler) []+                scrutinee <- [| W.requestMethod $(pure reqE) |]+                return $ CaseE scrutinee (methodMatches ++ [badMethodMatch])++mkYesodSubDispatch :: [ResourceTree a] -> Q Exp+mkYesodSubDispatch = mkYesodSubDispatchWith defaultOpts++-- | Like 'mkYesodSubDispatch', but threads a 'RouteOpts' into the generated+-- @yesodSubDispatch@ body. The only option that affects the body is+-- 'roNestedRouteFallthrough', which controls whether a subsite's top-level+-- parent clause falls through to a later sibling on an inner miss (mirroring+-- 'mkTopLevelDispatchInstance'). 'mkYesodSubDispatch' keeps the opts-less+-- signature for backwards compatibility.+--+-- This standalone entry point never delegates a parent's dispatch to a+-- same-splice 'YesodSubDispatchNested' instance: when called on its own there+-- are no such instances being generated alongside it (delegating would emit a+-- reference to a missing instance). 'mkYesodSubDispatchInstanceOpts', which+-- /does/ generate the matching nested instances in the same splice, uses+-- 'mkYesodSubDispatchWithDelegate' to opt into delegation.+--+-- @since 1.7.0.0+mkYesodSubDispatchWith :: RouteOpts -> [ResourceTree a] -> Q Exp+mkYesodSubDispatchWith = mkYesodSubDispatchWithDelegate NoSameSpliceNestedInstances++-- | The body-generation core shared by the standalone 'mkYesodSubDispatchWith'+-- and the instance-generating 'mkYesodSubDispatchInstanceOpts'. The+-- 'SameSpliceNestedInstances' argument says whether the caller emits the+-- per-parent 'YesodSubDispatchNested' instances in the same splice — see that+-- type for what each choice means for the generated body.+--+-- @since 1.7.0.0+mkYesodSubDispatchWithDelegate+    :: SameSpliceNestedInstances -> RouteOpts -> [ResourceTree a] -> Q Exp+mkYesodSubDispatchWithDelegate sameSplice routeOpts res = do+    let mds = (mkMDS+                return+                [|subHelper|]+                [|subTopDispatch|])+                { mdsNestedTarget = SubsiteNested+                , mdsNestedRouteFallthrough = roNestedRouteFallthrough routeOpts+                , mdsSameSpliceNestedInstances = sameSplice+                }+    (_childNames, clause') <-+        mkDispatchClause+            NoTyArgs+            mds+            res+    inner <- newName "inner"+    let innerFun = FunD inner [clause']+    helper <- newName "helper"+    let fun = FunD helper+                [ Clause+                    []+                    (NormalB $ VarE inner)+                    [innerFun]+                ]+    return $ LetE [fun] (VarE helper)+++subTopDispatch ::+    (YesodSubDispatch sub master) =>+        (forall content. ToTypedContent content =>+            SubHandlerFor child master content ->+            YesodSubRunnerEnv child master ->+            Maybe (Route child) ->+            W.Application+        ) ->+        (mid -> sub) ->+        (Route sub -> Route mid) ->+        YesodSubRunnerEnv mid master ->+        W.Application+subTopDispatch _ getSub toParent env =+    yesodSubDispatch+        ( YesodSubRunnerEnv+            { ysreParentRunner = ysreParentRunner env+            , ysreGetSub = getSub . ysreGetSub env+            , ysreToParentRoute = ysreToParentRoute env . toParent+            , ysreParentEnv = ysreParentEnv env+            }+        )++mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b+mkMDS unwrapper runHandlerE subDispatcher = MkDispatchSettings+    { mdsRunHandler = runHandlerE+    , mdsSubDispatcher = subDispatcher+    , mdsGetPathInfo = [|W.pathInfo|]+    , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]+    , mdsMethod = [|W.requestMethod|]+    , mds404 = [|void notFound|]+    , mds405 = [|void badMethod|]+    , mdsGetHandler = defaultGetHandler+    , mdsUnwrapper = unwrapper+    , mdsNestedRouteFallthrough = False+    , mdsNestedTarget = TopLevelNested+    , mdsSameSpliceNestedInstances = NoSameSpliceNestedInstances+    }++-- | Parse the foundation-type string given to @mkYesod@ into its components:+-- the type-constructor name, its type arguments, and the @=>@ class-context+-- groups (each a class name applied to type arguments). Returns 'Left' with a+-- parse-error message on malformed input.+--+-- @since 1.7.0.0+parseYesodName :: String -> Either String (String, [String], [[String]])+parseYesodName name = do+    either (Left . show) Right $ parse parseName "" name+    where+        parseName = do+            cxt <- option [] parseContext+            name' <- parseWord+            args <- many parseWord+            spaces+            eof+            return ( name', args, cxt)++        parseWord = do+            spaces+            many1 alphaNum++        parseContext = try $ do+            cxts <- parseParen parseContexts+            spaces+            _ <- string "=>"+            return cxts++        parseParen p = do+            spaces+            _ <- char '('+            r <- p+            spaces+            _ <- char ')'+            return r++        parseContexts =+            sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())
+ src/Yesod/Routes/TH/Internal.hs view
@@ -0,0 +1,412 @@++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Yesod.Routes.TH.Internal where++import Prelude hiding (exp)+import Data.List (foldl')+import Data.Maybe (mapMaybe)+-- newName is hidden so the only one in scope is the 'Quote' class method+-- (re-exported by th-compat); with template-haskell < 2.17 the monomorphic+-- 'Language.Haskell.TH.Syntax.newName' is a distinct, ambiguous name.+import Language.Haskell.TH.Syntax hiding (newName)+import Language.Haskell.TH.Syntax.Compat (Quote(..))+import Web.PathPieces (fromPathPiece, fromPathMultiPiece)+import Yesod.Routes.TH.Types++conPCompat :: Name -> [Pat] -> Pat+conPCompat n pats = ConP n+#if MIN_VERSION_template_haskell(2,18,0)+                         []+#endif+                         pats++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing++mkTupE :: [Exp] -> Exp+mkTupE =+    TupE+#if MIN_VERSION_template_haskell(2,16,0)+        . fmap Just+#endif++-- | The expression form of a route's accumulated @ParentArgs@: @()@ when there+-- are no dynamic pieces, the lone expression when there is one, and a tuple of+-- them otherwise. This is the single spelling of the unit\/single\/tuple idiom+-- that recurred across the dispatch and render-route clause builders.+parentArgsExprFromExps :: [Exp] -> Exp+parentArgsExprFromExps []  = ConE '()+parentArgsExprFromExps [e] = e+parentArgsExprFromExps es  = mkTupE es++-- | 'parentArgsExprFromExps' for the common case where the arguments are plain+-- variable names.+parentArgsExpr :: [Name] -> Exp+parentArgsExpr = parentArgsExprFromExps . map VarE++-- | The /pattern/ form of a route's accumulated @ParentArgs@, for binding the+-- incoming parent arguments: @_@ when there are none (the @ParentArgs@ is @()@+-- and ignored), the lone variable when there is one, and a tuple otherwise.+parentArgsPat :: [Name] -> Pat+parentArgsPat []  = WildP+parentArgsPat [a] = VarP a+parentArgsPat as  = TupP (map VarP as)++-- | The /type/ form of a route's accumulated @ParentArgs@: the unit type when+-- there are no dynamic pieces, the lone type when there is one, and a tuple+-- type otherwise.+parentArgsType :: [Type] -> Type+parentArgsType []  = ConT ''()+parentArgsType [t] = t+parentArgsType ts  = foldl' AppT (TupleT (length ts)) ts++-- | The number of type parameters a type constructor declares (0 for a type+-- that isn't a data\/newtype\/type-synonym, or that we can't reify).+typeArity :: Name -> Q Int+typeArity typeName = do+    info <- reify typeName+    pure $ case info of+        TyConI (DataD _ _ vs _ _ _) -> length vs+        TyConI (NewtypeD _ _ vs _ _ _) -> length vs+        TyConI (TySynD _ vs _) -> length vs+        _ -> 0++-- | Look up a type by 'Name' and return it fully applied with fresh+-- type variables. This is needed because nested route datatypes may+-- have type parameters (e.g., @NestedR subsite@), and TH functions+-- like 'isInstance' require fully-applied (kind 'Type') heads.+--+-- The application is to the datatype's /own/ reified 'typeArity', so the head+-- is saturated exactly — neither under- nor over-applied — and is therefore+-- well-kinded by construction. This holds for higher-kinded parameters too:+-- a parameter declared @(f :: Type -> Type)@ is filled with a bare,+-- unannotated @'VarT' a@, and GHC infers @a :: Type -> Type@ from the+-- datatype's declared kind, so we don't need to reconstruct each parameter's+-- kind ourselves. (Saturating by some /other/ arity — e.g. a caller's+-- 'TyArgs' count — is what historically built ill-kinded heads and made+-- 'isInstance' throw; see 'nestedInstanceExists'.)+fullyApplyType :: Name -> Q Type+fullyApplyType typeName = do+    arity <- typeArity typeName+    vars <- mapM (\i -> VarT <$> newName ("a" ++ show i)) [1..arity]+    pure $ foldl' AppT (ConT typeName) vars++-- | A route datatype name paired with the result of resolving it in the+-- current splice environment. 'rcResolved' is 'Just' when the datatype is+-- already in scope (defined in an earlier splice or a separately compiled+-- module) and 'Nothing' when it is not yet — typically because it is being+-- generated in the same splice group.+--+-- The point is to resolve a route name /once/, at the boundary, and carry the+-- answer in a value rather than re-running 'lookupTypeName' at each use site+-- and independently re-deciding what an unresolved name means. The two+-- consumers that matter — \"does its nested instance already exist?\"+-- ('nestedInstanceExists') and \"what type head do I splice?\"+-- ('appliedRouteTypeCon') — then share a single resolution.+--+-- @since 1.7.0.0+data RouteCon = RouteCon+    { rcName     :: String       -- ^ the route datatype name as written+    , rcResolved :: Maybe Name   -- ^ the resolved 'Name', if in scope+    }++-- | Resolve a route datatype name with 'lookupTypeName'. This is the single+-- boundary at which a route name is looked up; downstream code branches on the+-- resulting 'RouteCon' instead of resolving again.+--+-- @since 1.7.0.0+resolveRouteCon :: String -> Q RouteCon+resolveRouteCon name = RouteCon name <$> lookupTypeName name++-- | Does an instance of the given (nested-discovery) class — e.g.+-- @''YesodDispatchNested@, @''RenderRouteNested@, @''ParseRouteNested@,+-- @''RouteAttrsNested@ — already exist for this route datatype? This is the+-- single delegation probe shared by all the generators: when it answers 'True'+-- the parent delegates to the existing instance, and when 'False' it inlines+-- (or generates) the child itself.+--+-- Two rules, applied uniformly so the probe can never abort a splice:+--+--   * An unresolved 'RouteCon' (the datatype is being generated in the same+--     splice) trivially has no instance yet, so the answer is 'False'.+--   * A resolved one is saturated by its /own/ reified arity via+--     'fullyApplyType' — never by the site's 'TyArgs'. Applying the site's+--     type args to a child that was generated at a different arity (e.g. a+--     kind-'Type' child of a parameterized site) builds an ill-kinded head,+--     and 'isInstance' /throws/ a kind error rather than returning 'False',+--     aborting the splice. Saturating by the datatype's own arity keeps the+--     probed head well-kinded in every case.+--+-- /Can the abstract parameters make 'isInstance' fail?/ No. Once the head is+-- well-kinded (above), 'isInstance' answers by head unification — \"could+-- /any/ visible instance match this head?\" — which is a total query: it+-- returns 'True' or 'False' but cannot crash on an abstract @'VarT' a@. The+-- one theoretical imprecision is /over-matching/: because the argument is an+-- unconstrained variable, an instance written only at a more specific type+-- (e.g. @instance C (R Int)@) would still unify with @C (R a)@ and report+-- 'True'. That is harmless here because our codegen emits the nested-discovery+-- instances uniformly, one per route datatype at a fully abstract parameter+-- (e.g. @instance YesodDispatchNested (R a)@), so \"could match\" and \"does+-- match\" coincide — there is no narrower instance for the probe to confuse a+-- variable with. (Higher-kinded parameters are covered by the same argument;+-- see 'fullyApplyType'.)+--+-- @since 1.7.0.0+nestedInstanceExists :: Name -> RouteCon -> Q Bool+nestedInstanceExists klass rc =+    case rcResolved rc of+        Nothing       -> pure False+        Just typeName -> do+            appliedT <- fullyApplyType typeName+            isInstance klass [appliedT]++-- | The fully-applied route 'Type' for a 'RouteCon', as used for an instance+-- head. This is the single place the \"saturate by site 'TyArgs' vs. by the+-- datatype's own reified arity\" choice is made:+--+--   * With explicit 'TyArgs' (a parameterized site) the supplied type+--     arguments are applied to the constructor — the resolved 'Name' if in+--     scope, otherwise the bare 'mkName' (so a datatype being generated in the+--     same splice still gets a head to reference).+--   * With 'NoTyArgs' a resolved datatype is reified and saturated with fresh+--     type variables (needed for e.g. @mkYesodSubDispatch@, which doesn't know+--     the parent's type args); an unresolved one falls back to the bare+--     constructor.+--+-- @since 1.7.0.0+appliedRouteTypeCon :: RouteCon -> TyArgs -> Q Type+appliedRouteTypeCon rc tyargs =+    case (rcResolved rc, tyargs) of+        (Just typeName, NoTyArgs)     -> fullyApplyType typeName+        (Just typeName, SomeTyArgs{}) -> pure $ applyTyArgs (ConT typeName) tyargs+        (Nothing,       _)            -> pure $ applyTyArgs (ConT (mkName (rcName rc))) tyargs++-- | 'appliedRouteTypeCon' starting from the route datatype's name as a+-- 'String': resolve it ('resolveRouteCon') and apply the type arguments. The+-- fallback for an unresolved name (the bare constructor) is why this can't be+-- a plain @'lookupTypeName' >>=@ that requires the name to be in scope.+appliedRouteTypeNamed :: String -> TyArgs -> Q Type+appliedRouteTypeNamed routeName tyargs = do+    rc <- resolveRouteCon routeName+    appliedRouteTypeCon rc tyargs++-- | A subsite's type-constructor name. Distinct from 'RouteName' so the two+-- can't be swapped at a 'checkNestedSubArity' call site without a type error.+--+-- @since 1.7.0.0+newtype SubsiteName = SubsiteName String deriving (Eq, Show)++-- | A nested route datatype's name. See 'SubsiteName'.+--+-- @since 1.7.0.0+newtype RouteName = RouteName String deriving (Eq, Show)++-- | How many type arguments a subsite has. Distinct from 'RouteArity' so the+-- two arities can't be swapped (the equality predicate is symmetric, but the+-- error message is not).+--+-- @since 1.7.0.0+newtype SubsiteArity = SubsiteArity Int deriving (Eq, Show)++-- | The declared type-parameter arity of a nested route datatype. See+-- 'SubsiteArity'.+--+-- @since 1.7.0.0+newtype RouteArity = RouteArity Int deriving (Eq, Show)++-- | A detected mismatch between a subsite's type-argument count and its nested+-- route datatype's declared arity. Carrying the four facts (rather than a+-- pre-rendered 'String') lets the caller decide how to surface it and lets+-- tests assert on structure instead of substring-matching a message.+--+-- @since 1.7.0.0+data ArityMismatch = ArityMismatch+    { amSubsiteName  :: SubsiteName+    , amRouteName    :: RouteName+    , amSubsiteArity :: SubsiteArity+    , amRouteArity   :: RouteArity+    } deriving (Eq, Show)++-- | Validate that a parameterized subsite's nested route datatype carries+-- exactly as many type parameters as the subsite has type arguments: 'Nothing'+-- when the arities match, or a structured 'ArityMismatch' otherwise.+--+-- 'mkYesodSubDispatchInstance' applies the subsite's type arguments to each+-- nested route datatype (e.g. @NestedR subsite@) and uses the result directly+-- as the head of a @YesodSubDispatchNested@ instance, which expects a fully+-- applied (kind 'Type') route. So the arities must match exactly:+--+--   * Too few parameters on the nested datatype (e.g. it was generated by+--     plain 'mkYesodSubData', kind 'Type') over-applies it.+--   * Too many leaves it partially applied (kind @Type -> ...@).+--+-- Either way the result is a kind error reported deep inside generated code.+-- Surfacing it here (the caller passes the 'ArityMismatch' to 'fail') turns+-- it into an actionable, attributable message.+--+-- Pure so it can be unit-tested directly.+--+-- @since 1.7.0.0+checkNestedSubArity+    :: SubsiteName+    -> RouteName+    -> SubsiteArity+    -> RouteArity+    -> Maybe ArityMismatch+checkNestedSubArity subName routeName (SubsiteArity subArgs) (RouteArity nestedArity)+    | subArgs == nestedArity = Nothing+    | otherwise = Just $ ArityMismatch subName routeName (SubsiteArity subArgs) (RouteArity nestedArity)++-- | Which generator is running the arity check. The arity facts are identical+-- either way; this only steers 'arityMismatchMessage' so the failure names the+-- right entry point and calls the parameterized thing by its correct term+-- (a top-level site reached through the nested-dispatch recursion is not a+-- \"subsite\").+--+-- @since 1.7.0.0+data ArityCallSite+    = SubsiteCall   -- ^ a subsite, generated by 'mkYesodSubDispatchInstance'+    | TopLevelCall  -- ^ a top-level site's nested-dispatch recursion+    deriving (Eq, Show)++-- | Run 'checkNestedSubArity' for a (possibly unresolved) nested route+-- datatype and 'fail' with 'arityMismatchMessage' on a mismatch. A no-op when+-- the datatype is not in scope — an unresolved name has no knowable arity, so+-- the error (if any) surfaces from the generated code instead. This is the+-- single arity-guard shared by 'mkYesodSubDispatchInstance' and the nested+-- dispatch-instance recursion.+--+-- @since 1.7.0.0+assertNestedSubArity :: ArityCallSite -> SubsiteName -> SubsiteArity -> RouteCon -> Q ()+assertNestedSubArity callSite subName subArity rc =+    case rcResolved rc of+        Nothing -> pure ()+        Just tyname -> do+            nestedArity <- typeArity tyname+            maybe (pure ()) (fail . arityMismatchMessage callSite) $+                checkNestedSubArity subName (RouteName (rcName rc)) subArity (RouteArity nestedArity)++-- | The actionable @fail@ message for an 'ArityMismatch', phrased for the+-- 'ArityCallSite' that detected it.+--+-- @since 1.7.0.0+arityMismatchMessage :: ArityCallSite -> ArityMismatch -> String+arityMismatchMessage callSite (ArityMismatch (SubsiteName subName) (RouteName routeName) (SubsiteArity subArgs) (RouteArity nestedArity)) =+    concat+        [ prefix, ": the nested route datatype `", routeName+        , "` has ", show nestedArity, " type parameter(s), but the ", term, " `"+        , subName, "` has ", show subArgs+        , ". The subroute datatypes must carry exactly the ", term, "'s type "+        , "parameter(s) — generate the ", term, "'s routes with "+        , "`mkYesodSubDataOpts (setParameterizedSubroute True defaultOpts) ...` "+        , "so a parameterized ", term, " gets parameterized subroutes."+        ]+  where+    (prefix, term) = case callSite of+        SubsiteCall  -> ("mkYesodSubDispatchInstance", "subsite")+        TopLevelCall -> ("mkYesod", "site")++-- | Turn a single route piece into a match pattern, returning the freshly+-- bound 'Name' for dynamic pieces (and 'Nothing' for static ones). The+-- fresh-'Name' supply is the 'Quote' @m@ it runs in: the 'Q' code generators+-- run at 'Q' (hygienic 'newName'), while the pure, deterministic inline-parse+-- path runs at a 'Quote' instance over a monotonic counter (see the test+-- harness). This is the single source of truth for the+-- @ViewP fromPathPiece (Just x)@ dynamic encoding shared by the parse and+-- dispatch clause builders.+handlePieceM :: Quote m => Piece a -> m (Pat, Maybe Name)+handlePieceM (Static str) = pure (LitP $ StringL str, Nothing)+handlePieceM (Dynamic _) = mk <$> newName "dyn"+  where+    mk x = (ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]), Just x)++-- | The list form of 'handlePieceM' projecting the dynamic binders as 'Name's,+-- for callers that consume the bound variables directly (e.g. nested-dispatch+-- handler arguments).+handlePiecesNames :: Quote m => [Piece a] -> m ([Pat], [Name])+handlePiecesNames =+    fmap (\pps -> (map fst pps, mapMaybe snd pps)) . traverse handlePieceM++-- | The list form of 'handlePieceM' projecting the dynamic binders as 'VarE'+-- expressions, for callers that rebuild a route by applying its constructor to+-- the captured pieces.+handlePiecesM :: Quote m => [Piece a] -> m ([Pat], [Exp])+handlePiecesM =+    fmap (\(pats, names) -> (pats, map VarE names)) . handlePiecesNames++-- | Rebuild a route by applying its constructor (named by 'String', resolved+-- with 'mkName') to the captured dynamic-piece expressions — the companion to+-- 'handlePiecesM', which produces the @['Exp']@. This is the single spelling+-- of the @'foldl'' 'AppE' ('ConE' ('mkName' name))@ route-construction idiom+-- that recurred across the dispatch and parse clause builders.+applyConPieces :: String -> [Exp] -> Exp+applyConPieces name = foldl' AppE (ConE (mkName name))++-- | @composeE f g@ is the expression @f . g@.+composeE :: Exp -> Exp -> Exp+composeE f g = InfixE (Just f) (VarE '(.)) (Just g)++-- | @consE x xs@ is the expression @x : xs@.+consE :: Exp -> Exp -> Exp+consE x xs = InfixE (Just x) (ConE '(:)) (Just xs)++-- | How a path match pattern ends, after its matched piece patterns. Only+-- these four shapes are ever valid as a path tail, so making it a closed type+-- (rather than an arbitrary 'Pat') stops a caller from silently matching the+-- wrong number of segments — e.g. binding a @rest@ where the path was meant to+-- end exactly.+data PathTail+    = EndExact      -- ^ @[]@ — the path ends exactly here+    | EndRest Name  -- ^ bind the remaining segments to the given variable+    | EndWild       -- ^ @_@ — ignore any remaining segments+    | EndMulti Name -- ^ a trailing multipiece: @'fromPathMultiPiece' -> 'Just' n@++-- | The 'Pat' a 'PathTail' denotes (the seed the matched piece patterns are+-- consed onto in 'mkPathPat').+pathTailPat :: PathTail -> Pat+pathTailPat EndExact     = conPCompat '[] []+pathTailPat (EndRest n)  = VarP n+pathTailPat EndWild      = WildP+pathTailPat (EndMulti n) = ViewP (VarE 'fromPathMultiPiece) (conPCompat 'Just [VarP n])++-- | Build a path match pattern: a list pattern of the given piece patterns+-- ending in the given 'PathTail'.+mkPathPat :: PathTail -> [Pat] -> Pat+mkPathPat tl = foldr (\x y -> conPCompat '(:) [x, y]) (pathTailPat tl)++-- | Generate a single-argument lambda expression with a fresh name.+-- Takes a base name hint, generates a unique 'Name', and passes it+-- to a callback that produces the lambda body. Returns the complete+-- 'LamE' expression.+--+-- For multi-argument lambdas, nest calls — @\\x y -> body@ is+-- equivalent to @\\x -> \\y -> body@.+mkLambda :: String -> (Name -> Q Exp) -> Q Exp+mkLambda hint mkBody = do+    n <- newName hint+    bdy <- mkBody n+    pure $ LamE [VarP n] bdy++-- | Given a target 'String', find the 'ResourceParent' in the+-- @['ResourceTree' a]@ corresponding to that target and return it.+-- Also return the @['Piece' a]@ captures that precede it.+findNestedRoute :: String -> [ResourceTree a] -> Maybe ([Piece a], [ResourceTree a])+findNestedRoute _ [] = Nothing+findNestedRoute target (res : ress) =+    case res of+        ResourceLeaf _ ->+            findNestedRoute target ress+        ResourceParent name _overlap _attrs pieces children -> do+            if name == target+                then Just (pieces, children)+                else+                    let mresult = findNestedRoute target children+                    in+                        case mresult of+                            Nothing -> do+                                findNestedRoute target ress+                            Just (typs, childRoute) -> do+                                Just (pieces <> typs, childRoute)
src/Yesod/Routes/TH/ParseRoute.hs view
@@ -1,47 +1,334 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+ module Yesod.Routes.TH.ParseRoute     ( -- ** ParseRoute       mkParseRouteInstance+    , mkParseRouteInstanceOpts+    , mkParseRouteInstanceFor+      -- ** Clause construction (monad-polymorphic over 'Quote'; testable purely)+    , buildInlineParseClauses+    , generateParseRouteClause     ) where +import qualified Control.Monad.Trans as Trans+import qualified Data.Set as Set+import Control.Monad import Yesod.Routes.TH.Types-import Language.Haskell.TH.Syntax-import Data.Text (Text)+import Language.Haskell.TH (varE, varP)+import Language.Haskell.TH.Syntax hiding (newName)+import Language.Haskell.TH.Syntax.Compat (Quote(..), unsafeQToQuote) import Yesod.Routes.Class-import Yesod.Routes.TH.Dispatch+import Yesod.Routes.TH.RenderRoute+import Control.Monad.State.Strict+import Yesod.Routes.TH.Internal -mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec-mkParseRouteInstance cxt typ ress = do-    cls <- mkDispatchClause-        MkDispatchSettings-            { mdsRunHandler = [|\_ _ x _ -> x|]-            , mds404 = [|error "mds404"|]-            , mds405 = [|error "mds405"|]-            , mdsGetPathInfo = [|fst|]-            , mdsMethod = [|error "mdsMethod"|]-            , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|]-            , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]-            , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|]-            , mdsUnwrapper = return-            }-        (map removeMethods ress)-    helper <- newName "helper"-    fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]-    return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)-        [ FunD 'parseRoute $ return $ Clause-            []-            (NormalB $ fixer `AppE` VarE helper)-            [FunD helper [cls]]-        ]+-- | The trailing @_ -> Nothing@ clause appended to every generated+-- @parseRoute@\/@parseRouteNested@: a path matching none of the preceding+-- clauses fails to parse.+missingRouteClause :: Clause+missingRouteClause = Clause [WildP] (NormalB (ConE 'Nothing)) []++mkParseRouteInstance :: TyArgs -> Cxt -> Type -> [ResourceTree a] -> Q [Dec]+mkParseRouteInstance =+    mkParseRouteInstanceOpts defaultOpts++-- | Generate a ParseRouteNested instance for a specific nested route target.+-- This is a convenience wrapper around mkParseRouteInstanceOpts with setFocusOnNestedRoute.+--+-- @since 1.7.0.0+mkParseRouteInstanceFor :: String -> [ResourceTree a] -> Q [Dec]+mkParseRouteInstanceFor target ress = do+    let opts = setFocusOnNestedRoute target defaultOpts+        targetType = ConT (mkName target)+    mkParseRouteInstanceOpts opts NoTyArgs [] targetType ress++-- | Generate the 'ParseRoute' instance (and, under nested discovery, the+-- accompanying 'ParseRouteNested' instances) for a site, honoring the supplied+-- 'RouteOpts' and the site's 'TyArgs'. The options-driven core that+-- 'mkParseRouteInstanceFor' and the @mkYesod@ entry points build on.+--+-- @since 1.7.0.0+mkParseRouteInstanceOpts :: RouteOpts -> TyArgs -> Cxt -> Type -> [ResourceTree a] -> Q [Dec]+mkParseRouteInstanceOpts routeOpts origTyargs cxt typ unfocusedRess =+    case discoveryMode routeOpts origTyargs of+        -- Backwards-compatible default: generate a single 'ParseRoute'+        -- instance with all nested routes inlined, and no 'ParseRouteNested'+        -- instances.+        InlineCompat -> do+            clausess <- mapM (buildInlineParseClauses id) unfocusedRess+            let allClauses = concat clausess <> [missingRouteClause]+            pure+                [ instanceD cxt (ConT ''ParseRoute `AppT` typ)+                    [ FunD 'parseRoute allClauses+                    ]+                ]+        NestedDiscovery -> do+            ress <- focusTarget unfocusedRess+            existingInstances <- existingNestedInstances ress+            (clauses, childNames) <- flip runStateT mempty $ traverse (generateParseRouteClause existingInstances routeOpts) ress++            childInstances <- fmap join $ forM (Set.toList childNames) $ \childName ->+                mkParseRouteInstanceOpts routeOpts { roFocusOnNestedRoute = Just childName } origTyargs cxt (targetTypeFor childName) ress++            let allClauses = clauses <> [missingRouteClause]++            let thisInstance =+                    case roFocusOnNestedRoute routeOpts of+                        Just target ->+                            instanceD cxt (ConT ''ParseRouteNested `AppT` targetTypeFor target)+                                [ FunD 'parseRouteNested allClauses+                                ]+                        Nothing ->+                            instanceD cxt (ConT ''ParseRoute `AppT` typ)+                                [ FunD 'parseRoute allClauses+                                ]++            pure $ thisInstance : childInstances   where-    -- We do this in order to ski the unnecessary method parsing-    removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res-    removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z+    -- The route datatype named by @name@, applied to the site's type arguments.+    targetTypeFor name = applyTyArgs (ConT (mkName name)) origTyargs -    removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res }+    -- Narrow to the focused subtree's children via the shared lookup, failing+    -- loudly (matching Dispatch/RenderRoute) when the target is missing rather+    -- than silently producing an always-'Nothing' 'ParseRouteNested' instance.+    focusTarget ts =+        case roFocusOnNestedRoute routeOpts of+            Just target ->+                case findNestedRoute target ts of+                    Nothing ->+                        fail $ "Target '" ++ target ++ "' was not found in resources."+                    Just (_prePieces, children) ->+                        pure children+            Nothing ->+                pure ts -    fixDispatch (Methods x _) = Methods x []-    fixDispatch x = x+-- | Probe (in 'Q') which of the given resources' top-level parents already+-- have a 'ParseRouteNested' instance. Pulling these compiler queries+-- ('isInstance', via 'nestedInstanceExists') out of 'generateParseRouteClause'+-- is what lets that generator be monad-polymorphic over 'Quote' — and thus+-- runnable, and testable, at a pure 'Quote' instance.+--+-- @since 1.7.0.0+existingNestedInstances :: [ResourceTree a] -> Q (Set.Set String)+existingNestedInstances ress = do+    flags <- mapM check ress+    pure $ Set.fromList (concat flags)+  where+    check (ResourceParent name _ _ _ _) = do+        rc <- resolveRouteCon name+        has <- nestedInstanceExists ''ParseRouteNested rc+        pure [name | has]+    check ResourceLeaf{} = pure [] -instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing+-- | Generate a single @parseRouteNested@-delegating clause for one resource+-- (under nested discovery). It records, into its 'StateT' accumulator, the+-- name of each parent that still needs a 'ParseRouteNested' instance generated.+--+-- The \"does this name already have an instance?\" decision is a compiler query+-- ('isInstance'), which would pin this to 'Q'; it is instead /hoisted out/ and+-- passed in as @existingInstances@, leaving only fresh-name generation as an+-- effect. That makes the generator monad-polymorphic over 'Quote': it runs at+-- 'Q' in production and at a pure 'Quote' instance (a monotonic counter) in+-- tests.+--+-- @since 1.7.0.0+generateParseRouteClause+    :: Quote m+    => Set.Set String+    -- ^ Route names that already have a 'ParseRouteNested' instance (so this+    -- clause should not re-request one). Computed by the caller in 'Q' via+    -- 'nestedInstanceExists'; pass 'mempty' in pure tests.+    -> RouteOpts+    -> ResourceTree a+    -> StateT (Set.Set String) m Clause+generateParseRouteClause existingInstances routeOpts resourceTree =+    case resourceTree of+        ResourceLeaf (Resource name pieces dispatch _ _check) -> do+            (pats, dyns) <- liftQ $ handlePiecesM pieces++            case dispatch of+                Methods multi _ -> do+                    (finalTail, dyns') <-+                        case multi of+                            Nothing ->+                                pure (EndExact, dyns)+                            Just _ -> do+                                multiName <- liftQ $ newName "multi"+                                pure (EndMulti multiName, dyns ++ [VarE multiName])++                    queryParamsName <- liftQ $ newName "_queryParams"+                    let route = applyConPieces name dyns'+                        jroute = ConE 'Just `AppE` route+                        pathPat = mkPathPat finalTail pats+                        pat = TupP [pathPat, VarP queryParamsName]+                    pure $ Clause [pat] (NormalB jroute) []++                Subsite _ _ -> do+                    restName <- liftQ $ newName "rest"+                    queryParamsName <- liftQ $ newName "_queryParams"++                    let route = applyConPieces name dyns+                        pathPat = mkPathPat (EndRest restName) pats+                        pat = TupP [pathPat, VarP queryParamsName]+                        tupExp = mkTupE [VarE restName, VarE queryParamsName]+                        expr = VarE 'fmap+                            `AppE` route+                            `AppE` (VarE 'parseRoute `AppE` tupExp)+                    pure $ Clause [pat] (NormalB expr) []++        ResourceParent name _check _attrs pieces _children -> do+            recordNameIfNotInstance name++            (pats, dyns) <- liftQ $ handlePiecesM pieces++            let route = applyConPieces name dyns++            restName <- liftQ $ newName "rest"+            queryParamsName <- liftQ $ newName "_queryParams"++            let parseRouteOnRest =+                    VarE 'parseRouteNested+                        `AppE` mkTupE [VarE restName, VarE queryParamsName]++            body <-+                    if roNestedRouteFallthrough routeOpts+                        then do+                            resultName <- liftQ $ newName "result"+                            let stmt = BindS (AsP resultName (conPCompat 'Just [WildP])) parseRouteOnRest+                                expr = VarE 'fmap `AppE` route `AppE` VarE resultName+                            pure $ GuardedB [(PatG [stmt], expr)]+                        else+                            pure $ NormalB (VarE 'fmap `AppE` route `AppE` parseRouteOnRest)++            let pat = TupP [mkPathPat (EndRest restName) pats, VarP queryParamsName]+            pure $ Clause [pat] body []++  where+    liftQ :: Monad n => n a -> StateT (Set.Set String) n a+    liftQ = Trans.lift++    -- Record that @name@ still needs a 'ParseRouteNested' instance generated.+    -- The instance-existence decision is hoisted out (into @existingInstances@,+    -- computed in 'Q' by the caller), so this stays pure.+    recordNameIfNotInstance name =+        unless (name `Set.member` existingInstances) $+            modify (Set.insert name)++-- | Backwards-compatible inline @parseRoute@ clause generation. It assembles+-- the @parseRoute@ clauses for the inline path directly as AST, drawing fresh+-- names from a 'Quote' name supply and building tuples\/applications by hand+-- rather than through quotation brackets+-- (brackets are monomorphic 'Q' before template-haskell 2.17; the one+-- exception goes through 'unsafeQToQuote').+--+-- Each call yields one clause per resource tree: a leaf is its own matching+-- clause, while a parent is a single clause that matches its path prefix and+-- then cases the remaining @(path, queryParams)@ over its children (their+-- clauses turned into match alternatives) ending in a @_ -> 'Nothing'@+-- fallback. That fallback is the commit-on-parent-prefix behaviour: once the+-- parent prefix matches, a child miss is a definite 'Nothing' rather than a+-- fall-through to a sibling top-level route.+--+-- It is monad-polymorphic in the name supply via 'Quote': production runs it at+-- 'Q' (so binders are hygienic 'newName's), while tests run it at a pure+-- 'Quote' instance backed by a monotonic counter, where names are deterministic+-- and the '[Clause]' output can be asserted on directly without splicing or+-- 'runQ'. Under the deterministic supply every name is a freshly-bound pattern+-- variable scoped to its clause, the shared counter keeps them distinct within a+-- tree, and it is threaded through the parent\/child recursion so a parent+-- binder never collides with a child's.+--+-- @since 1.7.0.0+buildInlineParseClauses+    :: Quote m+    => (Exp -> Exp)+    -- ^ Wrap a child-route expression in the accumulated parent constructors.+    -> ResourceTree a+    -> m [Clause]+buildInlineParseClauses wrap resourceTree =+    map matchToClause <$> buildInlineParseMatches wrap resourceTree+  where+    -- Each parse match is a single @(path, queryParams)@ pattern with a body,+    -- which is exactly a top-level @parseRoute@ clause. Total by construction —+    -- 'Match' and 'Clause' carry the same body\/@where@ shape — so no partial+    -- destructure is needed.+    matchToClause :: Match -> Clause+    matchToClause (Match pat body decs) = Clause [pat] body decs++-- | The matching alternatives behind 'buildInlineParseClauses', one per+-- resource tree. Producing 'Match'es (rather than 'Clause's) is what lets a+-- parent splice its children straight into a @case@: a leaf is one+-- @(path, queryParams)@ alternative, and a parent is one alternative that+-- matches its path prefix then cases the remaining @(path, queryParams)@ over+-- its children's alternatives, ending in a @_ -> 'Nothing'@ fallback. At top+-- level 'buildInlineParseClauses' turns each alternative back into its own+-- @parseRoute@ clause.+buildInlineParseMatches+    :: Quote m+    => (Exp -> Exp)+    -- ^ Wrap a child-route expression in the accumulated parent constructors.+    -> ResourceTree a+    -> m [Match]+buildInlineParseMatches wrap resourceTree =+    case resourceTree of+        ResourceLeaf (Resource name pieces dispatch _ _check) -> do+            (pats, dyns) <- handlePiecesM pieces+            case dispatch of+                Methods multi _ -> do+                    (finalTail, dyns') <-+                        case multi of+                            Nothing ->+                                pure (EndExact, dyns)+                            Just _ -> do+                                multiName <- newName "multi"+                                pure (EndMulti multiName, dyns ++ [VarE multiName])+                    queryParamsName <- newName "_queryParams"+                    let route = applyConPieces name dyns'+                        jroute = ConE 'Just `AppE` wrap route+                        pathPat = mkPathPat finalTail pats+                        pat = TupP [pathPat, VarP queryParamsName]+                    pure [Match pat (NormalB jroute) []]++                Subsite _ _ -> do+                    restName <- newName "rest"+                    queryParamsName <- newName "_queryParams"+                    subName <- newName "sub"+                    let route = applyConPieces name dyns+                        wrapSub = wrap (route `AppE` VarE subName)+                        pathPat = mkPathPat (EndRest restName) pats+                        pat = TupP [pathPat, VarP queryParamsName]+                    -- 'unsafeQToQuote' because brackets are monomorphic 'Q'+                    -- on template-haskell < 2.17. It is safe here: the only+                    -- effect a bracket performs is drawing hygiene names for+                    -- its binders, and this one has none (the lambda binder+                    -- comes from a splice).+                    expr <- unsafeQToQuote [e|+                        fmap+                            (\ $(varP subName) -> $(pure wrapSub) )+                            (parseRoute ( $(varE restName), $(varE queryParamsName) ) )+                        |]+                    pure [Match pat (NormalB expr) []]++        ResourceParent name _check _attrs pieces children -> do+            (pats, dyns) <- handlePiecesM pieces+            restName <- newName "rest"+            queryParamsName <- newName "_queryParams"+            let parentCon childRoute =+                    applyConPieces name dyns `AppE` childRoute+                wrap' = wrap . parentCon++            -- Build each child's matching alternative relative to the remaining+            -- @(rest, queryParams)@ scope, then fold them into a single @case@+            -- that commits at this parent: a child miss falls to the+            -- @_ -> Nothing@ alternative instead of escaping to a sibling+            -- top-level route.+            childMatches <- concat <$> mapM (buildInlineParseMatches wrap') children+            let restTup = mkTupE [VarE restName, VarE queryParamsName]+                fallbackMatch = Match WildP (NormalB (ConE 'Nothing)) []+                caseExpr = CaseE restTup (childMatches ++ [fallbackMatch])+                pathPat = mkPathPat (EndRest restName) pats+                pat = TupP [pathPat, VarP queryParamsName]+            pure [Match pat (NormalB caseExpr) []]
src/Yesod/Routes/TH/RenderRoute.hs view
@@ -1,167 +1,979 @@-{-# LANGUAGE TemplateHaskell, CPP #-}-module Yesod.Routes.TH.RenderRoute-    ( -- ** RenderRoute-      mkRenderRouteInstance-    , mkRouteCons-    , mkRenderRouteClauses-    ) 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---- | Generate the constructors of a route data type.-mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])-mkRouteCons rttypes =-    mconcat <$> mapM mkRouteCon rttypes-  where-    mkRouteCon (ResourceLeaf res) =-        return ([con], [])-      where-        con = NormalC (mkName $ resourceName res)-            $ map (\x -> (notStrict, x))-            $ concat [singles, multi, sub]-        singles = concatMap toSingle $ resourcePieces res-        toSingle Static{} = []-        toSingle (Dynamic typ) = [typ]--        multi = maybeToList $ resourceMulti res--        sub =-            case resourceDispatch res of-                Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]-                _ -> []--    mkRouteCon (ResourceParent name _check pieces children) = do-        (cons, decs) <- mkRouteCons children-#if MIN_VERSION_template_haskell(2,12,0)-        dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq])-#else-        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]-#endif-        return ([con], dec : decs)-      where-        con = NormalC (mkName name)-            $ map (\x -> (notStrict, x))-            $ singles ++ [ConT $ mkName name]--        singles = concatMap toSingle pieces-        toSingle Static{} = []-        toSingle (Dynamic typ) = [typ]---- | Clauses for the 'renderRoute' method.-mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]-mkRenderRouteClauses =-    mapM go-  where-    isDynamic Dynamic{} = True-    isDynamic _ = False--    go (ResourceParent name _check pieces children) = do-        let cnt = length $ filter isDynamic pieces-        dyns <- replicateM cnt $ newName "dyn"-        child <- newName "child"-        let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]--        pack' <- [|pack|]-        tsp <- [|toPathPiece|]-        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns--        childRender <- newName "childRender"-        let rr = VarE childRender-        childClauses <- mkRenderRouteClauses children--        a <- newName "a"-        b <- newName "b"--        colon <- [|(:)|]-        let cons y ys = InfixE (Just y) colon (Just ys)-        let pieces' = foldr cons (VarE a) piecesSingle--        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)--        return $ Clause [pat] (NormalB body) [FunD childRender childClauses]--    go (ResourceLeaf res) = do-        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)-        dyns <- replicateM cnt $ newName "dyn"-        sub <--            case resourceDispatch res of-                Subsite{} -> return <$> newName "sub"-                _ -> return []-        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub--        pack' <- [|pack|]-        tsp <- [|toPathPiece|]-        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns--        piecesMulti <--            case resourceMulti res of-                Nothing -> return $ ListE []-                Just{} -> do-                    tmp <- [|toPathMultiPiece|]-                    return $ tmp `AppE` VarE (last dyns)--        body <--            case sub of-                [x] -> do-                    rr <- [|renderRoute|]-                    a <- newName "a"-                    b <- newName "b"--                    colon <- [|(:)|]-                    let cons y ys = InfixE (Just y) colon (Just ys)-                    let pieces = foldr cons (VarE a) piecesSingle--                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)-                _ -> do-                    colon <- [|(:)|]-                    let cons a b = InfixE (Just a) colon (Just b)-                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]--        return $ Clause [pat] (NormalB body) []--    mkPieces _ _ [] _ = []-    mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns-    mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns-    mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"---- | 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 cxt typ ress = do-    cls <- mkRenderRouteClauses ress-    (cons, decs) <- mkRouteCons ress-#if 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)-#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)-#endif-    return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)-        [ did-        , FunD (mkName "renderRoute") cls-        ]-        : sds ++ decs-  where-    clazzes standalone = if standalone `xor` null cxt then-          clazzes'-        else-          []-    clazzes' = [''Show, ''Eq, ''Read]--notStrict :: Bang-notStrict = Bang NoSourceUnpackedness NoSourceStrictness--instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+-- 'TemplateHaskellQuotes' is not enough here: on GHC < 9.0 it does not+-- enable nested @$(...)@ splices inside brackets (they parse as the @$@+-- operator and trigger cross-stage 'Lift' errors).+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module Yesod.Routes.TH.RenderRoute+    ( -- ** RenderRoute+      mkRenderRouteInstanceOpts+    , mkRouteConsOpts+    , shouldCreateResources++    , RouteOpts+    , defaultOpts+    , setEqDerived+    , setShowDerived+    , setReadDerived+    , setCreateResources+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute+    , roFocusOnNestedRoute+    , roNestedRouteFallthrough+    , setParameterizedSubroute+    , setNestedRouteFallthrough+    , DiscoveryMode(..)+    , discoveryMode+    ) where++import Data.Maybe+import Yesod.Routes.TH.Types+import Language.Haskell.TH (varE, varP)+import Language.Haskell.TH.Syntax+import Control.Monad+import Data.Text (pack)+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))+import Yesod.Routes.Class+import Data.Foldable+import Yesod.Routes.TH.Internal+import Data.Char+import Yesod.Core.Class.Dispatch.ToParentRoute++-- | 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, 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+    { roDerivedEq   :: Bool+    , roDerivedShow :: Bool+    , roDerivedRead :: Bool+    , roCreateResources :: Bool+    , roFocusOnNestedRoute :: Maybe String+    -- ^ If this option is set, then we will only generate datatypes for+    -- the nested subroute that matches this string.+    --+    -- @since 1.7.0.0+    , roParameterizedSubroute :: Bool+    , roNestedRouteFallthrough :: Bool+    -- ^ If 'True', then a nested route will fall through if it fails to+    -- match. If 'False', then a nested route will throw 'notFound' if it+    -- does not match.+    --+    -- Default: 'False'.+    --+    -- @since 1.7.0.0+    }++-- | Default options for generating routes.+--+-- The defaults are:+--+--   * 'setEqDerived', 'setShowDerived', 'setReadDerived': 'True' — derive+--     'Eq', 'Show' and 'Read' for the route datatype.+--   * 'setCreateResources': 'True' — emit the @resourcesSite ::+--     [ResourceTree String]@ term.+--   * 'setParameterizedSubroute': 'False' — subroutes are unparameterized.+--   * 'setFocusOnNestedRoute': unset — generate the whole route tree+--     rather than focusing on a single nested route.+--   * 'setNestedRouteFallthrough': 'False' — a nested route that fails to+--     match throws 'notFound' instead of falling through.+--+-- Use the @set*@ functions to override individual fields.+--+-- @since 1.6.25.0+defaultOpts :: RouteOpts+defaultOpts = MkRouteOpts+    { roDerivedEq = True+    , roDerivedShow = True+    , roDerivedRead = True+    , roCreateResources = True+    , roParameterizedSubroute = False+    , roFocusOnNestedRoute = Nothing+    , roNestedRouteFallthrough = False+    }++-- | If you set this with @routeName@, then the code generation will+-- generate code for the @routeName@ to be imported in the main dispatch+-- class. This allows you to generate code in separate modules.+--+-- Example:+--+-- First, you would put your route definitions into their own file.+--+-- @+-- module App.Routes.Resources where+--+-- import Yesod.Core+--+-- appResources :: [ResourceTree String]+-- appResources = [parseRoutes|+--     /  HomeR GET+--+--     /nest NestR:+--         /     NestIndexR GET POST+--         /#Int NestShowR  GET POST+--+-- |]+-- @+--+-- We have defined a nested route called @NestR@ here. A nested route is+-- created with the @:@ after the route name.+--+-- Then, in a module for the route specifically, we can generate the route+-- datatype and instances for later hooking in to the main instance.+--+-- @+-- module App.Routes.NestR where+--+-- import App.Routes.Resources+-- import Yesod.Core+--+-- mkYesodOpts (setFocusOnNestedRoute "NestR" defaultOpts) "App" appResources+-- @+--+-- If you only want to generate the datatypes, you can separate things+-- further using 'mkYesodDataOpts' and 'mkYesodDispatchOpts'.+--+-- Finally, import that type into your main yesod macro code.+--+-- @+-- module App where+--+-- import App.Routes.Resources (appResources)+-- import App.Routes.NestR (NestR(..))+--+-- mkYesod "App" appResources+-- @+--+-- The call to 'mkYesod' will delegate to the generated code for @NestR@+-- rather than regenerating it.+--+-- By default, 'defaultOpts' starts unfocused (the whole route tree is+-- generated). Use 'unsetFocusOnNestedRoute' to clear a previously-set focus.+--+-- For a full walkthrough — including subsites, linking to nested routes, and+-- why split sites should enable 'setNestedRouteFallthrough' — see the guide at+-- <https://github.com/yesodweb/yesod/blob/master/yesod-core/docs/split-route-compilation.md>.+--+-- @since 1.7.0.0+setFocusOnNestedRoute :: String -> RouteOpts -> RouteOpts+setFocusOnNestedRoute str rdo = rdo { roFocusOnNestedRoute = Just str }++-- | Clear any nested-route focus set by 'setFocusOnNestedRoute', so that+-- the whole route tree is generated.+--+-- 'defaultOpts' already starts unfocused, so this is only needed to undo a+-- previous 'setFocusOnNestedRoute'.+--+-- @since 1.7.0.0+unsetFocusOnNestedRoute :: RouteOpts -> RouteOpts+unsetFocusOnNestedRoute rdo = rdo { roFocusOnNestedRoute = Nothing }++-- | When 'True', a nested route that fails to match falls through to the+-- enclosing dispatch rather than throwing 'notFound'. When 'False', a+-- non-matching nested route throws 'notFound'.+--+-- Default: 'False'.+--+-- @since 1.7.0.0+setNestedRouteFallthrough :: Bool -> RouteOpts -> RouteOpts+setNestedRouteFallthrough b rdo = rdo { roNestedRouteFallthrough = b }++-- | When 'True', derive an 'Eq' instance for the route datatype.+--+-- Default: 'True'.+--+-- @since 1.6.25.0+setEqDerived :: Bool -> RouteOpts -> RouteOpts+setEqDerived b rdo = rdo { roDerivedEq = b }++-- | When 'True', derive a 'Show' instance for the route datatype.+--+-- Default: 'True'.+--+-- @since 1.6.25.0+setShowDerived :: Bool -> RouteOpts -> RouteOpts+setShowDerived b rdo = rdo { roDerivedShow = b }++-- | When 'True', derive a 'Read' instance for the route datatype.+--+-- Default: 'True'.+--+-- @since 1.6.25.0+setReadDerived :: Bool -> RouteOpts -> RouteOpts+setReadDerived b rdo = rdo { roDerivedRead = b }++-- | Determine whether or not to generate the @resourcesApp@ value.+--+-- Disabling this can be useful if you are creating the @routes ::+-- [ResourceTree String]@ elsewhere in your module, and referring to it+-- here. The @resourcesApp@ can become very large in large applications,+-- and duplicating it can result in signifiacntly higher compile times.+--+-- Default: 'True'.+--+-- @since 1.6.28.0+setCreateResources :: Bool -> RouteOpts -> RouteOpts+setCreateResources b rdo = rdo { roCreateResources = b }++-- | Returns whether or not we should create the @resourcesSite ::+-- [ResourceTree String]@ value during code generation.+--+-- @since 1.6.28.0+shouldCreateResources :: RouteOpts -> Bool+shouldCreateResources = roCreateResources++-- | If True, generate nested-discovery code (separate subroute datatypes and+-- @RenderRouteNested@ / dispatch instances) for a /parameterized/ site instead+-- of the backwards-compatible inline output. The subroute datatypes then carry+-- the parent site's type variables so that the @ParentSite@ \/ @ParentArgs@+-- associated types stay well-scoped.+--+-- Because the generated nested instances are parameterized over the site's+-- type variables, the splice emits instance heads with non-variable arguments;+-- a module using this typically needs @FlexibleContexts@, @FlexibleInstances@,+-- @MultiParamTypeClasses@, @TypeFamilies@ and, for a parameterized subsite+-- whose @master@ is determined by the @subsite@ (a @subsite -> master@+-- functional dependency on the user's class), @UndecidableInstances@.+--+-- Monomorphic sites always use nested discovery regardless of this flag; see+-- 'discoveryMode'.+--+-- Default: 'False'.+--+-- @since 1.6.28.0+setParameterizedSubroute :: Bool -> RouteOpts -> RouteOpts+setParameterizedSubroute b rdo = rdo { roParameterizedSubroute = b }++-- |+--+-- @since 1.6.25.0+instanceNamesFromOpts :: RouteOpts -> [Name]+instanceNamesFromOpts MkRouteOpts {..} = prependIf roDerivedEq ''Eq $ prependIf roDerivedShow ''Show $ prependIf roDerivedRead ''Read []+    where prependIf b = if b then (:) else const id++-- | How a route datatype's children are generated.+--+-- @since 1.7.0.0+data DiscoveryMode+    = -- | The backwards-compatible default for a /parameterized/ site that has+      -- not opted in: subroute datatypes stay unparameterized (kind 'Type')+      -- and @renderRoute@ \/ @parseRoute@ \/ dispatch inline the children,+      -- exactly as pre-nested-discovery Yesod did. Generating the discovery+      -- machinery here would put the parent's type variables out of scope on+      -- the child datatype, so we don't.+      InlineCompat+    | -- | Generate the "nested route discovery" machinery: parameterized+      -- subroute datatypes plus the @RenderRouteNested@ \/ @ParseRouteNested@+      -- \/ @YesodDispatchNested@ \/ @ToParentRoute@ \/ @UrlToDispatch@ \/+      -- @RedirectUrl@ instances and the delegating method bodies that go with+      -- them.+      NestedDiscovery+    deriving (Eq, Show)++-- | Classify how a route datatype's children should be generated, given the+-- site's route options and its 'TyArgs'.+--+-- 'NestedDiscovery' is chosen when any of the following hold:+--+--   * The site has /no/ type parameters ('hasTyArgs' is 'False', e.g. a+--     monomorphic site like @App@). Subroute datatypes then need no type+--     variables, so the machinery is always safe, and this preserves the+--     historical behaviour of monomorphic sites (including splitting nested+--     routes across modules).+--+--   * Parameterized subroutes were explicitly requested+--     ('setParameterizedSubroute'). The subroute datatypes then carry the+--     parent's type variables so the @ParentSite@ \/ @ParentArgs@ associated+--     types are well-scoped.+--+--   * We are focusing on a nested route for module-splitting+--     ('setFocusOnNestedRoute').+--+-- @since 1.7.0.0+discoveryMode :: RouteOpts -> TyArgs -> DiscoveryMode+discoveryMode opts tyargs+    | not (hasTyArgs tyargs)             = NestedDiscovery+    | roParameterizedSubroute opts       = NestedDiscovery+    | isJust (roFocusOnNestedRoute opts) = NestedDiscovery+    | otherwise                          = InlineCompat++-- | 'PlainTV' across template-haskell versions. @th-abstraction@ covers this,+-- but the version it was introduced in isn't always available — and the+-- 'TyVarBndr' /flag/ type also varies by version, so the result type is+-- CPP-guarded too. Used to build the type-variable binders of generated+-- subroute datatypes.+plainTVCompat :: Name ->+#if MIN_VERSION_template_haskell(2,21,0)+    TyVarBndr BndrVis+#elif MIN_VERSION_template_haskell(2,17,0)+    TyVarBndr ()+#else+    TyVarBndr+#endif+plainTVCompat =+#if MIN_VERSION_template_haskell(2,21,0)+    (`PlainTV` BndrReq)+#elif MIN_VERSION_template_haskell(2,17,0)+    (`PlainTV` ())+#else+    PlainTV+#endif++-- | Build the data constructor for a route leaf: @LeafR ty… [multi] [Route Sub]@.+-- Shared by the full-tree ('mkRouteConsOpts') and focused-nested+-- ('mkRenderRouteNestedInstanceOpts') constructor generators, which previously+-- spelled this identically.+leafRouteCon :: Resource Type -> Con+leafRouteCon res =+    NormalC (mkName $ resourceName res)+        $ map (notStrict,)+        $ concat [singles, multi, sub]+  where+    singles = concatMap toSingle $ resourcePieces res+    toSingle Static{}      = []+    toSingle (Dynamic typ) = [typ]+    multi = maybeToList $ resourceMulti res+    sub =+        case resourceDispatch res of+            Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]+            _ -> []++-- | Build the data constructor for a route parent: @ParentR ty… (ChildR tyargs…)@,+-- whose trailing field is the (possibly type-argument-applied) child route+-- datatype. Shared by the full-tree and focused-nested constructor generators.+parentRouteCon :: String -> [Piece Type] -> TyArgs -> Con+parentRouteCon name pieces tyargs =+    NormalC (mkName name)+        $ map (notStrict,)+        $ singles ++ [applyTyArgs (ConT (mkName name)) tyargs]+  where+    singles = concatMap toSingle pieces+    toSingle Static{}      = []+    toSingle (Dynamic typ) = [typ]++-- | The deriving context for a child\/subroute datatype. The site's instance+-- context only makes sense on a child that actually carries the type+-- arguments; an unparameterized child (the backwards-compatible default)+-- can't, so deriving with that context would leave the variables ambiguous.+-- Nullify the context in that case, mirroring historical Yesod.+childDerivCxt :: TyArgs -> Cxt -> Cxt+childDerivCxt tyargs cxt+    | hasTyArgs tyargs = cxt+    | otherwise        = []++-- | Generate the constructors of a route data type, with custom+-- 'RouteOpts'.+--+-- The first element in the return is the list of constructors for the+-- @Route site@ datatype. The second element is the list of 'Dec' to+-- declare nested datatypes or class instances of the 'RenderRouteNested'+-- for those instances.+--+-- @since 1.6.25.0+mkRouteConsOpts :: RouteOpts -> Cxt -> TyArgs -> Type -> [ResourceTree Type] -> Q ([Con], [Dec])+mkRouteConsOpts opts cxt origTyargs master resourceTrees = do+    (prePieces, focusedTrees) <-+        case roFocusOnNestedRoute opts of+            Nothing ->+                pure ([], resourceTrees)+            Just target -> do+                let mnestedRoute = findNestedRoute target resourceTrees+                case mnestedRoute of+                    Nothing ->+                        fail $ "Target '" <> target <> "' was not found in resources."+                    Just r ->+                        pure r+    mkRouteConsOpts' prePieces focusedTrees+  where+    -- When nested route discovery is enabled, child datatypes carry the+    -- parent's type variables, because RenderRouteNested has associated type+    -- families (ParentSite, ParentArgs) that reference the parent type;+    -- without the type variables on the child datatype, they'd be out of+    -- scope on the RHS of the type family instance.+    --+    -- When it is disabled (the backwards-compatible default), child+    -- datatypes are unparameterized (kind 'Type'), matching the historical+    -- output. See 'discoveryMode'. Computed once and reused below.+    mode = discoveryMode opts origTyargs+    tyargs =+        case mode of+            NestedDiscovery -> origTyargs+            InlineCompat    -> NoTyArgs+    subrouteDecTypeArgs = fmap plainTVCompat (tyArgsBinders tyargs)++    -- Derives for the child (subroute) datatypes. See 'childDerivCxt'.+    childCxt = childDerivCxt tyargs cxt+    (inlineDerives, mkStandaloneDerives) = getDerivesFor opts childCxt++    mkRouteConsOpts' :: [Piece Type] -> [ResourceTree Type] -> Q ([Con], [Dec])+    mkRouteConsOpts' prePieces trees = do+        results <- mapM (mkRouteCon prePieces) trees+        pure (mconcat results)++    mkRouteCon :: [Piece Type] -> ResourceTree Type -> Q ([Con], [Dec])+    mkRouteCon _ (ResourceLeaf res) =+        -- A leaf is always a constructor of the (possibly focused) datatype:+        -- in focus mode we have already narrowed @resourceTrees@ to the+        -- target's children, so every leaf reached here is a leaf of the+        -- focused route.+        pure ([leafRouteCon res], [])++    mkRouteCon prePieces (ResourceParent name _check _attrs pieces children) = do+        -- Accumulate pieces for children: combine parent pieces with this route's pieces+        let accumulatedPieces = prePieces <> pieces+        (cons, decs) <- mkRouteConsOpts' accumulatedPieces children+        let childDataName = mkName name++        -- Generate the child datatype if it has not been generated+        -- already, but only if we are *not* focusing on some other+        -- datatype.+        mname' <- lookupTypeName name+        mdec <- case mname' of+            Just _ -> do+                -- datatype already exists, definitely don't generate it+                pure Nothing+            Nothing -> do+                let childData = mkChildDataGen childDataName cons inlineDerives+                    childDataType = applyTyArgs (ConT childDataName) tyargs+                case roFocusOnNestedRoute opts of+                    Just target | target /= name ->+                        -- If we have a target, and this ain't it, don't+                        -- generate+                        pure Nothing+                    _ | InlineCompat <- mode ->+                        -- Backwards-compatible default: emit just the+                        -- (unparameterized) child datatype and its standalone+                        -- derives. No RenderRouteNested instance; renderRoute+                        -- inlines the children.+                        pure $ Just (childData : mkStandaloneDerives childDataType)+                    _ ->+                        -- Nested discovery: either `Just target | target ==+                        -- name` (matching a target, and this is it) or+                        -- `Nothing` (no target, or we already found it). Emit+                        -- the child datatype plus its RenderRouteNested+                        -- instance so the parent's renderRoute can delegate.+                        Just <$>+                            nestedChildDataAndInstance+                                opts cxt childCxt tyargs master childDataName cons+                                (prePieces <> pieces) children++        return ([parentRouteCon name pieces tyargs], maybe id (<>) mdec decs)+      where+        mkChildDataGen :: Name -> [Con] -> [DerivClause] -> Dec+        mkChildDataGen childDataName cons conts =+            DataD [] childDataName subrouteDecTypeArgs Nothing cons conts++-- | The shared preamble for rendering a 'ResourceParent': fresh names for the+-- parent's dynamic pieces and for the wrapped @child@ route, plus the+-- constructor pattern @Name dyn… child@ binding them. Returns the dynamic+-- names, the child name, and the pattern.+parentConPat :: String -> [Piece a] -> Q ([Name], Name, Pat)+parentConPat name pieces = do+    let cnt = length [() | Dynamic{} <- pieces]+    dyns <- replicateM cnt $ newName "dyn"+    child <- newName "child"+    pure (dyns, child, conPCompat (mkName name) $ map VarP $ dyns ++ [child])++-- | Is this path piece a dynamic capture, as opposed to a static segment?+isDynamic :: Piece t -> Bool+isDynamic Dynamic{} = True+isDynamic _ = False++-- | Render a route's path pieces to a list of @Text@-valued expressions,+-- pairing each 'Dynamic' piece with its bound variable in order. Fails the+-- splice if the piece list and the binder list are out of sync (a dynamic+-- piece with no corresponding bound variable).+mkPieces :: (String -> Exp) -> Exp -> [Piece t] -> [Name] -> Q [Exp]+mkPieces _ _ [] _ = pure []+mkPieces toText tsp (Static s:ps) dyns = (toText s :) <$> mkPieces toText tsp ps dyns+mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = (tsp `AppE` VarE d :) <$> mkPieces toText tsp ps dyns+mkPieces _ _ (Dynamic _ : _) [] =+    fail "RenderRoute.mkPieces: a dynamic path piece has no corresponding bound variable (route definition and piece-binder list are out of sync)"++-- | Clauses for the 'renderRoute' method. This should be called from the+-- instance derivation for 'RenderRoute'.+mkRenderRouteClauses :: RouteOpts -> TyArgs -> [ResourceTree Type] -> Q [Clause]+mkRenderRouteClauses opts origTyargs =+    goList+  where+    goList = fmap mconcat . mapM go++    mode = discoveryMode opts origTyargs++    go (ResourceParent name _check _attrs pieces children) =+        case mode of+            -- Opted in to nested discovery: the parent's renderRoute delegates+            -- to the child's RenderRouteNested instance.+            NestedDiscovery -> goNested+            -- Backwards-compatible default: inline the child clauses,+            -- prepending this parent's path pieces, exactly as historical+            -- Yesod did.+            InlineCompat -> goInline+      where+        goNested = do+            (dyns, child, pat) <- parentConPat name pieces++            body <- [| renderRouteNested $(pure (parentArgsExpr dyns)) $(pure (VarE child)) |]+            pure [Clause [pat] (NormalB body) []]++        goInline = do+            (dyns, child, pat) <- parentConPat name pieces++            pack' <- [|pack|]+            tsp <- [|toPathPiece|]+            piecesSingle <- mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns++            childRender <- newName "childRender"+            childClauses <- goList children++            body <- delegatingBody piecesSingle (VarE childRender) (VarE child)++            pure [Clause [pat] (NormalB body) [FunD childRender childClauses]]++    go (ResourceLeaf res) = do+        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)+        dyns <- replicateM cnt $ newName "dyn"+        sub <-+            case resourceDispatch res of+                Subsite{} -> return <$> newName "sub"+                _ -> return []+        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub++        pack' <- [|pack|]+        tsp <- [|toPathPiece|]+        piecesSingle <- mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns++        piecesMulti <-+            case resourceMulti res of+                Nothing -> return $ ListE []+                Just{} -> do+                    tmp <- [|toPathMultiPiece|]+                    return $ tmp `AppE` VarE (last dyns)++        body <-+            case sub of+                [x] -> do+                    rr <- [|renderRoute|]+                    delegatingBody piecesSingle rr (VarE x)+                _ ->+                    return $ mkTupE [foldr consE piecesMulti piecesSingle, ListE []]++        return [Clause [pat] (NormalB body) []]++-- | Build a renderRoute body that delegates its tail to another render+-- function — either a nested child's @renderRouteNested@ (the inline+-- 'ResourceParent' arm) or an embedded subsite's @renderRoute@ (the+-- 'ResourceLeaf' subsite arm). The path-piece list passed in is prepended to+-- the delegate's path list (callers include any parent pieces themselves) and+-- the query string is threaded through unchanged.+delegatingBody+    :: [Exp]    -- ^ this route's own path pieces (already including any parent pieces)+    -> Exp      -- ^ the delegate render function+    -> Exp      -- ^ the child/subsite route argument to render+    -> Q Exp+delegatingBody piecesSingle rr childArg = do+    a <- newName "a"+    b <- newName "b"+    let pieces' = foldr consE (VarE a) piecesSingle+    [e| ( \ ( $(varP a), $(varP b) ) -> ( $(pure pieces'), $(varE b) ) )+        ( $(pure rr) $(pure childArg) )+        |]++-- | Like 'mkRenderRouteClauses', but instead generates clauses for the+-- definition of 'renderRouteNested'.+--+-- @since 1.7.0.0+mkRenderRouteNestedClauses+    :: [Either String Name]+    -- ^ Either the static path piece or the names of the tuple of the parent arg.+    --+    -- These are both necessary to re-synthesize the total route.+    -> [ResourceTree Type]+    -> Q [Clause]+mkRenderRouteNestedClauses parentArgsNames resources = do+    fmap mconcat . mapM go $ resources+  where+    go (ResourceParent name _check _attrs pieces _children) = do+        (dyns, child, pat) <- parentConPat name pieces++        -- Extract parent dynamic variables from parentArgsNames+        let parentDyns = mapMaybe (either (const Nothing) Just) parentArgsNames++        -- Accumulate parent args: combine parent dynamic vars with this route's dynamic vars+        let allDyns = parentDyns ++ dyns+            accumulatedParentArgsExp = parentArgsExpr allDyns++        -- The body should call renderRouteNested with accumulated parent args+        body <- [| renderRouteNested $(pure accumulatedParentArgsExp) $(pure (VarE child)) |]+        pure [Clause [parentArgsPat parentDyns, pat] (NormalB body) []]++    go (ResourceLeaf res) = do+        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)+        dyns <- replicateM cnt $ newName "dyn"+        sub <-+            case resourceDispatch res of+                Subsite{} -> return <$> newName "sub"+                _ -> return []+        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub++        pack' <- [|pack|]+        tsp <- [|toPathPiece|]++        -- Build the FULL path including parent pieces+        -- parentArgsNames contains Either String Name for each piece in the parent path+        let parentDyns = mapMaybe (either (const Nothing) Just) parentArgsNames++        -- Build parent path pieces from parentArgsNames+        parentPieces <- mkParentPieces pack' tsp parentArgsNames parentDyns+        -- Build this resource's own pieces+        thisResourcePieces <- mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns++        piecesMulti <-+            case resourceMulti res of+                Nothing -> return $ ListE []+                Just{} -> do+                    tmp <- [|toPathMultiPiece|]+                    return $ tmp `AppE` VarE (last dyns)++        body <-+            case sub of+                [x] -> do+                    rr <- [|renderRoute|]+                    -- Combine parent pieces with this resource's pieces+                    delegatingBody (parentPieces ++ thisResourcePieces) rr (VarE x)+                _ -> do+                    colon <- [|(:)|]+                    let cons a b = InfixE (Just a) colon (Just b)+                    -- Combine parent pieces with this resource's pieces+                    let allPieces = parentPieces ++ thisResourcePieces+                    return $ mkTupE [foldr cons piecesMulti allPieces, ListE []]++        return [Clause [parentArgsPat parentDyns, pat] (NormalB body) []]++    -- Build path pieces from parentArgsNames (which contains both static and dynamic pieces)+    mkParentPieces :: Exp -> Exp -> [Either String Name] -> [Name] -> Q [Exp]+    mkParentPieces pack' tsp parentArgsNames' parentDyns = goParentPieces parentArgsNames' parentDyns+      where+        goParentPieces [] _ = pure []+        goParentPieces (Left staticStr : rest) dyns =+            ((pack' `AppE` LitE (StringL staticStr)) :) <$> goParentPieces rest dyns+        goParentPieces (Right _ : rest) (dyn : dyns) =+            ((tsp `AppE` VarE dyn) :) <$> goParentPieces rest dyns+        goParentPieces (Right _ : _) [] =+            fail "RenderRoute.mkParentPieces: a dynamic parent path piece has no corresponding bound variable"++-- | The shared core of every 'RenderRouteNested' instance body. From a parent+-- route's accumulated path pieces and its child resources it computes the+-- @ParentArgs@ tuple 'Type' and the @renderRouteNested@ method clauses. The+-- three instance-emitting sites (the inline child datatype in+-- 'mkRenderRouteInstanceOpts', the focused target in+-- 'mkRenderRouteNestedInstanceOpts', and that target's nested children) differ+-- only in the instance head, the @ParentSite@ right-hand side, and the context+-- they wrap around this — so only those wrappers remain at the call sites, and+-- the piece-naming\/clause-building boilerplate (including the dynamic-binder+-- name derivation) lives here once.+renderRouteNestedBody+    :: [Piece Type]            -- ^ accumulated parent path pieces+    -> [ResourceTree Type]     -- ^ child resources+    -> Q (Type, [Clause])      -- ^ (ParentArgs tuple type, renderRouteNested clauses)+renderRouteNestedBody prepieces children = do+    let piecesAndNames =+            map (\p -> case p of+                    Static str -> Left str+                    Dynamic a -> Right a)+                prepieces+        preDyns = mapMaybe (either (const Nothing) Just) piecesAndNames+    let parentDynT = parentArgsType preDyns+    parentNames <- forM piecesAndNames $ \epiece'name ->+        case epiece'name of+            Left piece -> pure (Left piece)+            Right t ->+                case filter isAlphaNum (show t) of+                    (a : as) -> Right <$> newName (toLower a : as)+                    []       -> fail+                        "renderRouteNested: a dynamic piece's type renders with no alphanumeric characters, so no binder name can be derived from it"+    childClauses <- mkRenderRouteNestedClauses parentNames children+    pure (parentDynT, childClauses)++-- | Generate the 'RenderRoute' instance.+--+-- This includes both the 'Route' associated type and the+-- 'renderRoute' method.  This function uses both 'mkRouteConsOpts' and+-- 'mkRenderRouteClauses'.+--+-- @since 1.6.25.0+mkRenderRouteInstanceOpts+    :: RouteOpts+    -> Cxt+    -- ^ The context passed around for the instances+    -> TyArgs+    -- ^ Type arguments+    -> Type+    -- ^ The type of the foundation resource+    -> [ResourceTree Type]+    -- ^ The actual tree of routes to generate code for+    -> Q [Dec]+mkRenderRouteInstanceOpts opts cxt tyargs typ ress = do+    case roFocusOnNestedRoute opts of+        Nothing -> do+            cls <- mkRenderRouteClauses opts tyargs ress+            (cons, decs) <- mkRouteConsOpts opts cxt tyargs typ ress+            let did = DataInstD []+#if MIN_VERSION_template_haskell(2,15,0)+                    Nothing routeDataName+#else+                    ''Route [typ]+#endif+                    Nothing cons inlineDerives+            -- ToParentRoute instances are only needed by the nested-discovery+            -- machinery; the backwards-compatible default emits none.+            parentRouteInstancesDecs <-+                case discoveryMode opts tyargs of+                    NestedDiscovery -> mkToParentRouteInstances cxt tyargs ress+                    InlineCompat    -> pure []+            pure $ mconcat+                [ pure $ instanceD cxt (ConT ''RenderRoute `AppT` typ)+                    [ did+                    , FunD 'renderRoute cls+                    ]+                , mkStandaloneDerives routeDataName+                , decs+                , parentRouteInstancesDecs+                ]+        Just target ->+            case findNestedRoute target ress of+                Nothing ->+                    fail $ "Target '" <> target <> "' was not found in resources."+                Just (prepieces, ress') ->+                    mkRenderRouteNestedInstanceOpts opts cxt tyargs typ prepieces target ress'+  where+    routeDataName = ConT ''Route `AppT` typ+    (inlineDerives, mkStandaloneDerives) = 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++-- | For each datatype, generate an instance of 'ToParentRoute' for the+-- datatype. Instances should mostly look like this:+--+-- > instance ToParentRoute FooR where+-- >     toParentRoute (a0, a1) = FooR a0 a1+mkToParentRouteInstances :: Cxt -> TyArgs -> [ResourceTree Type] -> Q [Dec]+mkToParentRouteInstances cxt origTyargs ress = do+    mconcat <$> mapM (go ([], [])) ress+  where+    go _ (ResourceLeaf _) =+        pure []+    go (accPieces, parentConstructors) (ResourceParent name _check _attrs pieces children) = do+        -- Extract dynamic types from accumulated parent pieces+        let accDynTypes = [t | Dynamic t <- accPieces]+        accDynVars <- mapM (\_ -> newName "parent") accDynTypes++        -- Extract dynamic types from this route's pieces+        let piecesDynTypes = [t | Dynamic t <- pieces]+        piecesDynVars <- mapM (\_ -> newName "piece") piecesDynTypes++        -- Child route variable+        child <- newName "child"++        -- ParentArgs includes BOTH acc and pieces dynamic vars+        let allParentDynVars = accDynVars ++ piecesDynVars++        -- Build the full route by applying all parent constructors+        -- We need to partition allParentDynVars according to each constructor's piece count+        let applyConToParentArgs = buildRouteExpr parentConstructors (mkName name) allParentDynVars (VarE child)++        let toParentRouteD =+                FunD 'toParentRoute+                    [ Clause+                        [parentArgsPat allParentDynVars, VarP child]+                        (NormalB applyConToParentArgs)+                        []+                    ]++        let thisInstance =+                instanceD cxt (ConT ''ToParentRoute `AppT` applyTypeVariables name) [toParentRouteD]++        -- Accumulate pieces and constructor info for children+        let thisPieceCount = length piecesDynTypes+            acc' =+                ( accPieces <> pieces+                , parentConstructors ++ [(mkName name, thisPieceCount)]+                )++        childrenInstances <- mconcat <$> mapM (go acc') children+        pure $ thisInstance : childrenInstances++    applyTypeVariables name =+        applyTyArgs (ConT (mkName name)) origTyargs++    -- Build the route expression by applying constructors from outermost to innermost+    buildRouteExpr :: [(Name, Int)] -> Name -> [Name] -> Exp -> Exp+    buildRouteExpr parentCtors thisCtor allDynVars childExpr =+        let -- All constructors including this one+            thisPieceCount = length allDynVars - sum (map snd parentCtors)+            allCtors = parentCtors ++ [(thisCtor, thisPieceCount)]++            -- Partition dynamic vars for each constructor+            partitionedVars = go' allDynVars allCtors+              where+                go' _ [] = []+                go' vars ((_, count) : rest) =+                    let (varsForThis, remaining) = splitAt count vars+                    in varsForThis : go' remaining rest++            -- Build expression from inside out using foldr+            finalExpr = foldr+                (\(ctorName, varsForThis) innerExpr ->+                    foldl' AppE (ConE ctorName) (map VarE varsForThis ++ [innerExpr]))+                childExpr+                (zip (map fst allCtors) partitionedVars)+        in finalExpr++notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness++-- | Assemble a @RenderRouteNested@ instance from the pieces that vary between+-- the three sites that emit one (the inline child datatype in+-- 'mkRouteConsOpts', the focused target and its nested children in+-- 'mkRenderRouteNestedInstanceOpts'). The context, child route 'Type',+-- @ParentSite@ right-hand side (the foundation 'Type') and @ParentArgs@ tuple+-- 'Type' plus the @renderRouteNested@ clauses are all that differ; everything+-- else is shared here.+--+-- @since 1.7.0.0+mkRenderRouteNestedInstanceD+    :: Cxt        -- ^ instance context+    -> Type       -- ^ the child route datatype (instance head argument)+    -> Type       -- ^ the @ParentSite@ right-hand side (the foundation type)+    -> Type       -- ^ the @ParentArgs@ tuple type+    -> [Clause]   -- ^ the @renderRouteNested@ method clauses+    -> Dec+mkRenderRouteNestedInstanceD instCxt childRouteType parentSiteRHS parentArgsT clauses =+    instanceD+        instCxt+        (ConT ''RenderRouteNested `AppT` childRouteType)+        [ TySynInstD $ TySynEqn Nothing (ConT ''ParentSite `AppT` childRouteType) parentSiteRHS+        , TySynInstD $ TySynEqn Nothing (ConT ''ParentArgs `AppT` childRouteType) parentArgsT+        , FunD 'renderRouteNested clauses+        ]++-- | Generate the declarations for a nested-discovery /child/ datatype: the+-- (parameterized) datatype declaration, its @RenderRouteNested@ instance, and+-- any standalone deriving clauses. Shared by every nested-discovery+-- constructor generator ('mkRouteConsOpts' and 'mkRenderRouteNestedInstanceOpts')+-- so the datatype shape, instance context, and @ParentSite@\/@ParentArgs@ wiring+-- stay in one place. The focus\/inline gating that decides /whether/ to emit+-- these stays at the call sites, since that differs between them.+--+-- @since 1.7.0.0+nestedChildDataAndInstance+    :: RouteOpts+    -> Cxt           -- ^ instance context for the @RenderRouteNested@ instance+    -> Cxt           -- ^ deriving context for the child datatype (nullified when+                     --   the child carries no type arguments; see 'mkRouteConsOpts')+    -> TyArgs        -- ^ type arguments carried by the child datatype+    -> Type          -- ^ the @ParentSite@ right-hand side (the foundation type)+    -> Name          -- ^ the child datatype name+    -> [Con]         -- ^ the child datatype's constructors+    -> [Piece Type]  -- ^ accumulated parent path pieces for this child+    -> [ResourceTree Type] -- ^ the child's own children+    -> Q [Dec]+nestedChildDataAndInstance opts instCxt derivCxt tyargs parentSiteRHS childDataName cons accPieces children = do+    let subrouteDecTypeArgs = fmap plainTVCompat (tyArgsBinders tyargs)+        (inlineDerives, mkStandaloneDerives) = getDerivesFor opts derivCxt+        childData = DataD [] childDataName subrouteDecTypeArgs Nothing cons inlineDerives+        childDataType = applyTyArgs (ConT childDataName) tyargs+    (parentDynT, childClauses) <- renderRouteNestedBody accPieces children+    let childInstance =+            mkRenderRouteNestedInstanceD instCxt childDataType parentSiteRHS parentDynT childClauses+    pure (childData : childInstance : mkStandaloneDerives childDataType)++mkRenderRouteNestedInstanceOpts+    :: RouteOpts+    -> Cxt+    -> TyArgs+    -> Type+    -> [Piece Type]+    -> String+    -> [ResourceTree Type]+    -> Q [Dec]+mkRenderRouteNestedInstanceOpts routeOpts cxt tyargs typ prepieces target ress = do+    -- Generate constructors for all children+    (cons, childDecs) <- mkFocusedChildCons prepieces ress++    let targetName = mkName target+        targetDecs =+            -- The focused target datatype and its RenderRouteNested instance+            -- are emitted through the same shared builder as the in-module+            -- and nested-child paths, so the instance context is plain @cxt@+            -- (matching the in-module generator); demanding extra+            -- Eq/Show/Read constraints on the site type arguments here would+            -- be undischargeable at the delegating RenderRoute instance.+            nestedChildDataAndInstance+                routeOpts cxt childCxt tyargs typ targetName cons prepieces ress++    -- Return the datatype declaration, instance, and any standalone derives,+    -- followed by the declarations for any nested children.+    (<> childDecs) <$> targetDecs+  where+    -- The focused datatype carries the site's type arguments. See 'childDerivCxt'.+    childCxt = childDerivCxt tyargs cxt++    -- Generate constructors and nested-instance declarations for the children+    -- of the focused target. Structurally similar to 'mkRouteConsOpts'' inner+    -- @mkRouteCon@, but deliberately NOT shared: there we are walking the whole+    -- site and must honour the focus gate (skip datatypes other than the+    -- target) and the InlineCompat branch. Here every tree is already *inside*+    -- the focused target, so each parent unconditionally gets its+    -- RenderRouteNested instance — applying the focus gate here would wrongly+    -- skip grandchild instances.+    mkFocusedChildCons :: [Piece Type] -> [ResourceTree Type] -> Q ([Con], [Dec])+    mkFocusedChildCons prePieces trees =+        mconcat <$> mapM (mkFocusedChildCon prePieces) trees++    mkFocusedChildCon :: [Piece Type] -> ResourceTree Type -> Q ([Con], [Dec])+    mkFocusedChildCon _ (ResourceLeaf res) =+        pure ([leafRouteCon res], [])++    mkFocusedChildCon prePieces (ResourceParent name _check _attrs pieces children) = do+        let accumulatedPieces = prePieces <> pieces+        (cons, decs) <- mkFocusedChildCons accumulatedPieces children+        let childDataName = mkName name++        -- Generate the child datatype and its RenderRouteNested instance unless+        -- the datatype already exists (generated by another split-out module).+        mname' <- lookupTypeName name+        mdec <- case mname' of+            Just _ -> pure Nothing+            Nothing ->+                Just <$>+                    nestedChildDataAndInstance+                        routeOpts cxt childCxt tyargs typ childDataName cons+                        accumulatedPieces children++        return ([parentRouteCon name pieces tyargs], maybe id (<>) mdec decs)
src/Yesod/Routes/TH/RouteAttrs.hs view
@@ -1,41 +1,117 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+ module Yesod.Routes.TH.RouteAttrs     ( mkRouteAttrsInstance+    , mkRouteAttrsInstanceFor+    , mkRouteAttrsNestedInstances     ) where  import Yesod.Routes.TH.Types+import Yesod.Routes.TH.Internal (nestedInstanceExists, resolveRouteCon, instanceD, conPCompat, findNestedRoute) import Yesod.Routes.Class import Language.Haskell.TH.Syntax-import Data.Set (fromList)-import Data.Text (pack)+import Data.Foldable (toList)+import qualified Data.Set  as Set+import qualified Data.Text as Text+import Control.Monad  mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance cxt typ ress = do-    clauses <- mapM (goTree id) ress+    clauses <- mapM (goTree Nothing id) ress     return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)-        [ FunD 'routeAttrs $ concat clauses+        [ FunD 'routeAttrs $ concat clauses +++                [Clause [ WildP ] (NormalB $ VarE 'mempty) []]         ] -goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]-goTree front (ResourceLeaf res) = return <$> goRes front res-goTree front (ResourceParent name _check pieces trees) =-    concat <$> mapM (goTree front') trees+-- | Like 'mkRouteAttrsInstance', but uses a 'String' name of a nested+-- subroute to generate nested instances instead of generating the full+-- instance for all routes.+--+-- @since 1.7.0.0+mkRouteAttrsInstanceFor :: Cxt -> Type -> String -> [ResourceTree a] -> Q [Dec]+mkRouteAttrsInstanceFor cxt typ target ress = do+    -- Fail loudly (matching Dispatch/RenderRoute/ParseRoute) when the focus+    -- target is missing, rather than silently emitting an always-'mempty'+    -- 'RouteAttrsNested' instance.+    case findNestedRoute target ress of+        Nothing ->+            fail $ "Target '" ++ target ++ "' was not found in resources."+        Just _ ->+            pure ()+    clauses <- mapM (goTree (Just target) id) ress+    return [instanceD cxt (ConT ''RouteAttrsNested `AppT` typ)+        [ FunD 'routeAttrsNested $ concat clauses +++                [Clause [ WildP ] (NormalB $ VarE 'mempty) []]+        ]+        ]++-- | Generate a 'RouteAttrsNested' instance for every nested parent route in+-- the tree (recursively), skipping any whose instance already exists (e.g. one+-- generated in another module when routes are split). This is the+-- 'RouteAttrs' counterpart to the @RenderRouteNested@ \/ @ParseRouteNested@ \/+-- @YesodDispatchNested@ instances that a plain 'mkYesod' already emits for its+-- child route fragments, so that @routeAttrsNested ChildR@ resolves for a+-- single-module site just like the other nested-delegation methods do.+--+-- @since 1.7.0.0+mkRouteAttrsNestedInstances :: Cxt -> TyArgs -> [ResourceTree a] -> Q [Dec]+mkRouteAttrsNestedInstances cxt tyargs ress =+    concat <$> mapM perParent (parentNames ress)   where+    parentNames trees = concat+        [ name : parentNames children+        | ResourceParent name _ _ _ children <- trees+        ]+    perParent name = do+        exists <- nestedInstanceExists ''RouteAttrsNested =<< resolveRouteCon name+        if exists+            then pure []+            else mkRouteAttrsInstanceFor cxt (applyTyArgs (ConT (mkName name)) tyargs) name ress++goTree :: Maybe String -> (Pat -> Pat) -> ResourceTree a -> Q [Clause]+goTree mtarget front (ResourceLeaf res) =+    case mtarget of+        Nothing ->+            return $ toList $ goRes front res+        Just _ ->+            return []+goTree (Just target) front (ResourceParent name _check _attrs _pieces trees)+    | target /= name = concat <$> mapM (goTree (Just target) front) trees+goTree mtarget front (ResourceParent name _check _attrs pieces trees) = do+    doesNestedInstanceExist <- nestedInstanceExists ''RouteAttrsNested =<< resolveRouteCon name++    if doesNestedInstanceExist+        then do+            x <- newName "x"+            pure [Clause [front (conPCompat (mkName name) (ignored (VarP x)))] (NormalB $ VarE 'routeAttrsNested `AppE` VarE x) []]+        else do+            -- We only reach this clause when @mtarget@ is 'Nothing' (full+            -- instance) or @Just name@ (we found the focus target); clause 2+            -- above peeled off the non-matching @Just other@ case. Either way+            -- the remaining subtree is generated unfocused (@Nothing@). The+            -- focus target itself is the route boundary, so its own+            -- constructor is not prepended (@front@); ordinary parents in the+            -- full instance do prepend theirs (@front'@).+            let front'' =+                    if Just name == mtarget+                        then front+                        else front'+            concat <$> mapM (goTree Nothing front'') trees+  where     ignored = (replicate toIgnore WildP ++) . return     toIgnore = length $ filter isDynamic pieces     isDynamic Dynamic{} = True     isDynamic Static{} = False-    front' = front . ConP (mkName name) . ignored+    front' = front . conPCompat (mkName name)+                   . ignored -goRes :: (Pat -> Pat) -> Resource a -> Q Clause-goRes front Resource {..} =+goRes :: (Pat -> Pat) -> Resource a -> Maybe Clause+goRes front Resource {..} = do+    guard (not (null resourceAttrs))     return $ Clause         [front $ RecP (mkName resourceName) []]-        (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs))+        (NormalB $ VarE 'Set.fromList `AppE` ListE (map toText resourceAttrs))         []   where-    toText s = VarE 'pack `AppE` LitE (StringL s)--instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing+    toText s = VarE 'Text.pack `AppE` LitE (StringL s)
src/Yesod/Routes/TH/Types.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveLift #-}+ -- | Warning! This module is considered internal and may have breaking changes module Yesod.Routes.TH.Types     ( -- * Data types@@ -9,6 +12,16 @@     , Dispatch (..)     , CheckOverlap     , FlatResource (..)+    , ParentDetails (..)+      -- * Route datatype type arguments+    , TyArgs (..)+    , toTyArgs+    , tyArgsList+    , tyArgsTypes+    , tyArgsBinders+    , tyArgsArity+    , hasTyArgs+    , applyTyArgs       -- ** Helper functions     , resourceMulti     , resourceTreePieces@@ -17,23 +30,88 @@     ) where  import Language.Haskell.TH.Syntax+import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Set (Set)+-- Provides Lift instance for Set in older versions of GHC+import Instances.TH.Lift () +-- | The type arguments of a route datatype, paired with the source 'Name' each+-- was derived from. A monomorphic site like @App@ has 'NoTyArgs'; a+-- parameterized one like @MySub subsite@ has 'SomeTyArgs'.+--+-- Carrying the (non-)emptiness in the type — rather than as a bare list with a+-- separate @null@ check — keeps \"are there type args?\" and \"what are they?\"+-- a single fact, so the populated branch hands you the 'NonEmpty' directly.+--+-- @since 1.7.0.0+data TyArgs+    = NoTyArgs+    | SomeTyArgs (NonEmpty (Type, Name))+    deriving (Eq, Show)++-- | Build 'TyArgs' from a list of (type, source-name) pairs.+--+-- @since 1.7.0.0+toTyArgs :: [(Type, Name)] -> TyArgs+toTyArgs []       = NoTyArgs+toTyArgs (x : xs) = SomeTyArgs (x :| xs)++-- | The type arguments as a plain list (empty for 'NoTyArgs').+--+-- @since 1.7.0.0+tyArgsList :: TyArgs -> [(Type, Name)]+tyArgsList NoTyArgs        = []+tyArgsList (SomeTyArgs ne) = NonEmpty.toList ne++-- | Just the 'Type's of the arguments, in order.+--+-- @since 1.7.0.0+tyArgsTypes :: TyArgs -> [Type]+tyArgsTypes = map fst . tyArgsList++-- | Just the source 'Name's of the arguments, in order.+--+-- @since 1.7.0.0+tyArgsBinders :: TyArgs -> [Name]+tyArgsBinders = map snd . tyArgsList++-- | How many type arguments there are.+--+-- @since 1.7.0.0+tyArgsArity :: TyArgs -> Int+tyArgsArity NoTyArgs        = 0+tyArgsArity (SomeTyArgs ne) = NonEmpty.length ne++-- | Whether there are any type arguments (i.e. the site is parameterized).+--+-- @since 1.7.0.0+hasTyArgs :: TyArgs -> Bool+hasTyArgs NoTyArgs      = False+hasTyArgs SomeTyArgs {} = True++-- | Apply the type arguments to a head type (e.g. a route\/subroute type+-- constructor), left to right. This replaces the ad-hoc+-- @'foldl'' 'AppT' con ('fst' '<$>' tyargs)@ that recurred across the+-- generators.+--+-- @since 1.7.0.0+applyTyArgs :: Type -> TyArgs -> Type+applyTyArgs t = foldl' AppT t . tyArgsTypes+ data ResourceTree typ     = ResourceLeaf (Resource typ)-    | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]-    deriving (Show, Functor)+    | ResourceParent String CheckOverlap (Set String) [Piece typ] [ResourceTree typ]+    deriving (Lift, Show, Functor, Foldable, Traversable)  resourceTreePieces :: ResourceTree typ -> [Piece typ] resourceTreePieces (ResourceLeaf r) = resourcePieces r-resourceTreePieces (ResourceParent _ _ x _) = x+resourceTreePieces (ResourceParent _ _ _ x _) = x  resourceTreeName :: ResourceTree typ -> String resourceTreeName (ResourceLeaf r) = resourceName r-resourceTreeName (ResourceParent x _ _ _) = x--instance Lift t => Lift (ResourceTree t) where-    lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]-    lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]+resourceTreeName (ResourceParent x _ _ _ _) = x  data Resource typ = Resource     { resourceName :: String@@ -42,23 +120,12 @@     , resourceAttrs :: [String]     , resourceCheck :: CheckOverlap     }-    deriving (Show, Functor)+    deriving (Lift, Show, Functor, Foldable, Traversable)  type CheckOverlap = Bool -instance Lift t => Lift (Resource t) where-    lift (Resource a b c d e) = [|Resource a b c d e|]- data Piece typ = Static String | Dynamic typ-    deriving Show--instance Functor Piece where-    fmap _ (Static s)  = Static s-    fmap f (Dynamic t) = Dynamic (f t)--instance Lift t => Lift (Piece t) where-    lift (Static s)  = [|Static  $(lift s)|]-    lift (Dynamic t) = [|Dynamic $(lift t)|]+    deriving (Lift, Show, Functor, Foldable, Traversable)  data Dispatch typ =     Methods@@ -69,23 +136,25 @@         { subsiteType :: typ         , subsiteFunc :: String         }-    deriving Show--instance Functor Dispatch where-    fmap f (Methods a b) = Methods (fmap f a) b-    fmap f (Subsite a b) = Subsite (f a) b--instance Lift t => Lift (Dispatch t) where-    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]-    lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]-    lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]+    deriving (Lift, Show, Functor, Foldable, Traversable)  resourceMulti :: Resource typ -> Maybe typ resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti _ = Nothing +-- | The details of a 'ResourceParent' gathered for a flattened resource: the+-- parent's name, its path pieces, and the route attributes it contributes to+-- its descendants.+--+-- @since 1.7.0.0+data ParentDetails a = ParentDetails+    { pdName :: String+    , pdPieces :: [Piece a]+    , pdAttrs :: Set String+    } deriving (Show)+ data FlatResource a = FlatResource-    { frParentPieces :: [(String, [Piece a])]+    { frParentDetails :: [ParentDetails a]     , frName :: String     , frPieces :: [Piece a]     , frDispatch :: Dispatch a@@ -96,6 +165,7 @@ flatten =     concatMap (go id True)   where-    go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)]-    go front check' (ResourceParent name check pieces children) =-        concatMap (go (front . ((name, pieces):)) (check && check')) children+    go front check' (ResourceLeaf (Resource a b c _ check)) =+        [FlatResource (front []) a b c (check' && check)]+    go front check' (ResourceParent name check attrs pieces children) =+        concatMap (go (front . ((ParentDetails name pieces attrs):)) (check && check')) children
test/Hierarchy.hs view
@@ -1,184 +1,109 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | Whole-tree end of the @Hierarchy@ split-codegen fixture: generates the+-- full @RenderRoute@\/@RouteAttrs@\/@ParseRoute@\/@YesodDispatch@ instances for+-- the shared tree (from "Hierarchy.ResourceTree") in one set of splices, and+-- supplies every leaf handler. The @Hierarchy.*@ sibling modules instead each+-- emit one focused nested fragment; importing them here checks the per-fragment+-- and whole-tree codegen agree. Drives the @test-routes@ suite's @hierarchy@ spec. module Hierarchy     ( hierarchy-    , Dispatcher (..)-    , runHandler-    , Handler2-    , App-    , toText-    , Env (..)-    , subDispatch     -- to avoid warnings     , deleteDelete2     , deleteDelete3+    , testRouteDatatype     ) where +import Yesod.Core import Test.Hspec import Test.HUnit-import Yesod.Routes.Parse import Yesod.Routes.TH import Yesod.Routes.Class import Language.Haskell.TH.Syntax-import Data.Text (Text, pack, unpack, append)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8+import Data.Text (Text) import qualified Data.Set as Set+import Hierarchy.Admin+import Hierarchy.ResourceTree+import Hierarchy.Nest+import Hierarchy.Nest2+import Hierarchy.Nest3+import Hierarchy.Nest2.NestInner -class ToText a where-    toText :: a -> Text+-- | Trivial handler synonym kept only for the @deleteDelete2@\/@deleteDelete3@+-- placeholder handlers below (which exist solely to silence+-- not-in-scope warnings for routes whose handlers are never invoked here).+type Handler site a = a -instance ToText Text where toText = id-instance ToText String where toText = pack+do+    fmap concat $ sequence+        [ mkRenderRouteInstanceOpts defaultOpts [] NoTyArgs (ConT ''Hierarchy) hierarchyResourcesWithType+        , pure <$> mkRouteAttrsInstance [] (ConT ''Hierarchy) hierarchyResourcesWithType+        , mkParseRouteInstance NoTyArgs [] (ConT ''Hierarchy) hierarchyResourcesWithType+        , mkYesodDispatchOpts defaultOpts "Hierarchy" hierarchyResources+        ] -type Handler2 sub master a = a-type Handler site a = Handler2 site site a+instance Yesod Hierarchy -type Request = ([Text], ByteString) -- path info, method-type App sub master = Request -> (Text, Maybe (Route master))-data Env sub master = Env-    { envToMaster :: Route sub -> Route master-    , envSub :: sub-    , envMaster :: master-    } -subDispatch-    :: (Env sub master -> App sub master)-    -> (Handler2 sub master Text -> Env sub master -> Maybe (Route sub) -> App sub master)-    -> (master -> sub)-    -> (Route sub -> Route master)-    -> Env master master-    -> App sub master-subDispatch handler _runHandler getSub toMaster env req =-    handler env' req-  where-    env' = env-        { envToMaster = envToMaster env . toMaster-        , envSub = getSub $ envMaster env-        }--class Dispatcher sub master where-    dispatcher :: Env sub master -> App sub master+getAfter :: HandlerFor site Text+getAfter = pure "after"+getHomeR :: HandlerFor site Text+getHomeR = pure "homer" -runHandler-    :: ToText a-    => Handler2 sub master a-    -> Env sub master-    -> Maybe (Route sub)-    -> App sub master-runHandler h Env {..} route _ = (toText h, fmap envToMaster route)+getBackwardsR :: Int -> HandlerFor site Text+getBackwardsR _i = pure "backwards" -data Hierarchy = Hierarchy+getGet3 :: HandlerFor site Text+getGet3 = pure "getget3" -do-    let resources = [parseRoutes|-/ HomeR GET+postPost3 :: HandlerFor site Text+postPost3 = pure "postPost3" -----------------------------------------+getNestInnerIndexR :: HandlerFor site Text+getNestInnerIndexR = pure "getNestInnerIndexR" -/!#Int BackwardsR GET+getGetPostR :: HandlerFor site Text+getGetPostR = pure "getGetPostR" -/admin/#Int AdminR:-    /            AdminRootR GET-    /login       LoginR     GET POST-    /table/#Text TableR     GET+postGetPostR :: HandlerFor site Text+postGetPostR = pure "postGetPostR" -/nest/ NestR !NestingAttr:+getGet2 :: HandlerFor site Text+getGet2 = pure "getGet2" -  /spaces      SpacedR   GET !NonNested+postPost2 :: HandlerFor site Text+postPost2 = pure "postPost2" -  /nest2 Nest2:-    /           GetPostR  GET POST-    /get        Get2      GET-    /post       Post2         POST---    /#Int       Delete2            DELETE-  /nest3 Nest3:-    /get        Get3      GET-    /post       Post3         POST---    /#Int       Delete3            DELETE+getSpacedR :: HandlerFor site Text+getSpacedR = pure "getSpacedR" -/afterwards AfterR !parent !key=value1:-  /             After     GET !child !key=value2+getAdminRootR :: Int -> HandlerFor site Text+getAdminRootR _ = pure "getAdminRootR" --- /trailing-nest TrailingNestR:---  /foo TrailingFooR GET---  /#Int TrailingIntR GET-|]+getLoginR :: Int -> HandlerFor site Text+getLoginR _ = pure "getLoginR" -    rrinst <- mkRenderRouteInstance [] (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-        { mdsRunHandler = [|runHandler|]-        , mdsSubDispatcher = [|subDispatch|]-        , mdsGetPathInfo = [|fst|]-        , mdsMethod = [|snd|]-        , mdsSetPathInfo = [|\p (_, m) -> (p, m)|]-        , mds404 = [|pack "404"|]-        , mds405 = [|pack "405"|]-        , mdsGetHandler = defaultGetHandler-        , mdsUnwrapper = return-        } resources-    return-#if MIN_VERSION_template_haskell(2,11,0)-        $ InstanceD Nothing-#else-        $ InstanceD-#endif-            []-            (ConT ''Dispatcher-                `AppT` ConT ''Hierarchy-                `AppT` ConT ''Hierarchy)-            [FunD (mkName "dispatcher") [dispatch]]-        : prinst-        : rainst-        : rrinst+postLoginR :: Int -> HandlerFor site Text+postLoginR _ = pure "postLoginR" -getSpacedR :: Handler site String-getSpacedR = "root-leaf"+getTableR :: Int -> Text -> HandlerFor site Text+getTableR _ _ = pure "getTableR" -getGet2   :: Handler site String; getGet2 = "get"-postPost2 :: Handler site String; postPost2 = "post" deleteDelete2 :: Int -> Handler site String; deleteDelete2 = const "delete"-getGet3   :: Handler site String; getGet3 = "get"-postPost3 :: Handler site String; postPost3 = "post" deleteDelete3   :: Int -> Handler site String; deleteDelete3 = const "delete" -getAfter   :: Handler site String; getAfter = "after"--getHomeR :: Handler site String-getHomeR = "home"--getBackwardsR :: Int -> Handler site Text-getBackwardsR _ = pack "backwards"--getAdminRootR :: Int -> Handler site Text-getAdminRootR i = pack $ "admin root: " ++ show i--getLoginR :: Int -> Handler site Text-getLoginR i = pack $ "login: " ++ show i--postLoginR :: Int -> Handler site Text-postLoginR i = pack $ "post login: " ++ show i--getTableR :: Int -> Text -> Handler site Text-getTableR _ = append "TableR "--getGetPostR :: Handler site Text-getGetPostR = pack "get"--postGetPostR :: Handler site Text-postGetPostR = pack "post"-- hierarchy :: Spec hierarchy = describe "hierarchy" $ do     it "nested with spacing" $@@ -187,33 +112,92 @@         renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])     it "renders table correctly" $         renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])-    let disp m ps = dispatcher-            (Env-                { envToMaster = id-                , envMaster = Hierarchy-                , envSub = Hierarchy-                })-            (map pack ps, S8.pack m)+    describe "parseRoute" $ do+        let parseNothing = Nothing :: Maybe (Route Hierarchy)+        describe "HomeR" $ do+            it "works" $ do+                parseRoute ([], []) @?= Just HomeR+            it "with extraneous query params" $ do+                parseRoute ([], [("foo", "bar")]) @?= Just HomeR+        describe "AdminR" $ do+            it "works" $ do+                parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)+            it "fails with extra character" $ do+                parseRoute (["admin!", "5"], []) @?= parseNothing+            it "works with a subroute with param" $ do+                parseRoute (["admin", "6", "table", "hello"], []) @?= Just (AdminR 6 (TableR "hello"))+            describe "parseNestedRoute" $ do+                it "works" $ do+                    parseRouteNested ([], []) @?= Just AdminRootR+                it "works with param" $ do+                    parseRouteNested (["table", "hello"], []) @?= Just (TableR "hello")+        describe "NestR" $ do+            it "fails because there's no top-level handler" $ do+                parseRoute (["nest"], []) @?= parseNothing+            it "works for SpacedR" $ do+                parseRoute (["nest", "spaces"], []) @?= Just (NestR SpacedR)+            it "works with parseRouteNested" $ do+                parseRouteNested (["spaces"], []) @?= Just SpacedR+            describe "Nest2" $ do+                it "works" $ do+                    parseRoute (["nest", "nest2"], []) @?= Just (NestR (Nest2 GetPostR))+                describe "NestInner" $ do+                    it "works" $ do+                        parseRoute (["nest", "nest2", "nest-inner"], []) @?= Just (NestR (Nest2 (NestInner NestInnerIndexR)))+    describe "parseRouteNested" $ do+        describe "NestInner" $ do+            it "works" $ do+                parseRouteNested ([], []) @?= Just NestInnerIndexR+    describe "routeAttrs" $ do+        it "inherited attributes" $ do+            routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]+        it "pair attributes" $+            routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"] -    let testGetPost route getRes postRes = do-          let routeStrs = map unpack $ fst (renderRoute route)-          disp "GET" routeStrs @?= (getRes, Just route)-          disp "POST" routeStrs @?= (postRes, Just route)+        describe "NestingAttr inherits properly" $ do+            it "routeAttrs" $ do+                routeAttrs (NestR (Nest2 GetPostR)) @?= Set.fromList ["NestingAttr"]+            it "routeAttrsNested" $ do+                routeAttrsNested GetPostR @?= Set.fromList ["NestingAttr"]+            it "routeAttrsNested InnerNest" $ do+                routeAttrsNested NestInnerIndexR @?= Set.fromList ["NestingAttr"] -    it "dispatches routes with multiple METHODs: admin" $-        testGetPost (AdminR 1 LoginR) "login: 1" "post login: 1" -    it "dispatches routes with multiple METHODs: nesting" $-        testGetPost (NestR $ Nest2 GetPostR) "get" "post"+-- This value should compile if all routes are present as expected.+testRouteDatatype :: Route Hierarchy -> Int+testRouteDatatype r =+    case r of+        HomeR -> 0+        BackwardsR _ -> 1+        AdminR _ sub ->+            case sub of+                AdminRootR -> 0+                LoginR -> 0+                TableR _ -> 1+        NestR sub -> testNestR sub+        -- NOTE: This is a bug in the behavior of the parser. See issue+        -- https://github.com/yesodweb/yesod/issues/1886+        --+        -- Nest3, by layout, should be under `NestR`. However, since there+        -- is a comment on column 0, this causes the parser to reset the+        -- column count.+        Nest3 sub ->+            case sub of+                Get3 -> 0+                Post3 -> 0+        AfterR sub ->+            case sub of+                After -> 0 -    it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)-    it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")-    it "parses" $ do-        parseRoute ([], []) @?= Just HomeR-        parseRoute ([], [("foo", "bar")]) @?= Just HomeR-        parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)-        parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy))-    it "inherited attributes" $ do-        routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]-    it "pair attributes" $-        routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"]+testNestR :: NestR -> Int+testNestR sub =+    case sub of+        SpacedR -> 1+        Nest2 sub' ->+            case sub' of+                GetPostR -> 0+                Get2 -> 0+                Post2 -> 0+                NestInner sub'' ->+                    case sub'' of+                        NestInnerIndexR -> 0
+ test/Hierarchy/Admin.hs view
@@ -0,0 +1,29 @@+{-# language TemplateHaskell, ViewPatterns, OverloadedStrings, TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the @AdminR@ parent. Shows the+-- finer-grained helpers — @mkRenderRouteInstanceOpts@ /+-- @mkRouteAttrsInstanceFor@ / @mkParseRouteInstanceFor@ each scoped to+-- @"AdminR"@ — emitting that one fragment's instances against the shared+-- @hierarchyResourcesWithType@ tree, rather than the whole-tree splice in+-- "Hierarchy".+module Hierarchy.Admin where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Language.Haskell.TH+import Data.Text (Text)++mkRenderRouteInstanceOpts+    (setFocusOnNestedRoute "AdminR" defaultOpts)+    []+    NoTyArgs+    (ConT ''Hierarchy)+    hierarchyResourcesWithType+mkRouteAttrsInstanceFor+    []+    (ConT ''AdminR)+    "AdminR"+    $ hierarchyResourcesWithType+mkParseRouteInstanceFor+    "AdminR"+    $ hierarchyResourcesWithType
+ test/Hierarchy/Nest.hs view
@@ -0,0 +1,29 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns #-}+{-# language OverloadedStrings #-}+{-# language TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the top-level nested parent @NestR@+-- (which itself contains @Nest2@\/@Nest3@). Uses the canonical+-- @mkYesodDataOpts@ with @setFocusOnNestedRoute "NestR"@ to emit just that+-- fragment's route datatype + render\/attrs\/parse instances — the same+-- higher-level entry point a full Yesod site uses to split route compilation+-- across modules (see @yesod-core\/docs\/split-route-compilation.md@). Imports+-- the deeper @Nest2@\/@Nest3@\/@NestInner@ fragment modules so their+-- separately-emitted instances are in scope for @NestR@ to delegate to.+--+-- (Sibling fragments "Hierarchy.Admin", "Hierarchy.Nest2" and+-- "Hierarchy.Nest2.NestInner" instead drive the underlying+-- @mkRenderRouteInstanceOpts@ \/ @mkRouteAttrsInstanceFor@ \/+-- @mkParseRouteInstanceFor@ builders directly, so the route-level generators+-- that @mkYesodDataOpts@ bundles stay covered too.)+module Hierarchy.Nest where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Hierarchy.Nest3 ()+import Hierarchy.Nest2+import Hierarchy.Nest2.NestInner+import Yesod.Core++mkYesodDataOpts (setFocusOnNestedRoute "NestR" defaultOpts) "Hierarchy" hierarchyResources
+ test/Hierarchy/Nest2.hs view
@@ -0,0 +1,28 @@+{-# language TemplateHaskell, OverloadedStrings, ViewPatterns, TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the @Nest2@ parent. Emits @Nest2@'s+-- render\/attrs\/parse instances against the shared @hierarchyResourcesWithType@.+-- The top-of-module @do@ block is a compile-time assertion: it calls+-- @parseRouteNested@ for the deeper @NestInner@ fragment (whose instance is+-- emitted in "Hierarchy.Nest2.NestInner") and @fail@s the splice if parsing the+-- empty path does not yield @NestInnerIndexR@ — pinning cross-module nested parse.+module Hierarchy.Nest2 where++import Yesod.Routes.Class+import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Language.Haskell.TH+import Hierarchy.Nest3 ()+import Hierarchy.Nest2.NestInner++do+    let works = parseRouteNested ([], []) :: Maybe NestInner+    case works of+        Nothing ->+            fail "parsing fails"+        Just NestInnerIndexR ->+            pure []++mkRenderRouteInstanceOpts (setFocusOnNestedRoute "Nest2" defaultOpts) [] NoTyArgs (ConT ''Hierarchy) hierarchyResourcesWithType+mkRouteAttrsInstanceFor [] (ConT ''Nest2) "Nest2" $ hierarchyResourcesWithType+mkParseRouteInstanceFor "Nest2" $ hierarchyResourcesWithType
+ test/Hierarchy/Nest2/NestInner.hs view
@@ -0,0 +1,23 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns, OverloadedStrings #-}+{-# language TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the deepest nested parent+-- @NestInner@ (under @NestR@ > @Nest2@). Emits its render\/attrs\/parse+-- instances via @setFocusOnNestedRoute "NestInner"@ + the @*For@ helpers; the+-- @ParseRouteNested NestInner@ instance is what "Hierarchy.Nest2" asserts+-- against at compile time.+module Hierarchy.Nest2.NestInner where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Language.Haskell.TH++mkRenderRouteInstanceOpts+    (setFocusOnNestedRoute "NestInner" defaultOpts)+    []+    NoTyArgs+    (ConT ''Hierarchy)+    hierarchyResourcesWithType+mkRouteAttrsInstanceFor [] (ConT ''NestInner) "NestInner" $ hierarchyResourcesWithType+mkParseRouteInstanceFor "NestInner" $ hierarchyResourcesWithType
+ test/Hierarchy/Nest3.hs view
@@ -0,0 +1,16 @@+{-# language TemplateHaskell #-}+{-# language ViewPatterns #-}+{-# language OverloadedStrings #-}+{-# language TypeFamilies #-}++-- | @Hierarchy@ split fragment focused on the @Nest3@ parent. Demonstrates+-- @mkYesodDataOpts@ with @setFocusOnNestedRoute "Nest3"@ emitting just that+-- nested fragment's route datatype + instances, separate from the whole-tree+-- splice in "Hierarchy". Shares @hierarchyResources@ from "Hierarchy.ResourceTree".+module Hierarchy.Nest3 where++import Yesod.Routes.TH+import Hierarchy.ResourceTree+import Yesod.Core++mkYesodDataOpts (setFocusOnNestedRoute "Nest3" defaultOpts) "Hierarchy" hierarchyResources
+ test/Hierarchy/ResourceTree.hs view
@@ -0,0 +1,54 @@+{-# language TemplateHaskell #-}+{-# language QuasiQuotes #-}++-- | Shared resource tree + foundation type for the @Hierarchy@ split-codegen+-- fixture. The @Hierarchy.*@ sibling modules each focus on one nested parent+-- (NestR, Nest2, Nest3, NestInner, AdminR) via @setFocusOnNestedRoute@ and emit+-- that fragment's instances separately, while "Hierarchy" itself emits the+-- whole-tree instances; keeping the tree here lets every splice share it+-- without tripping the TH stage restriction. Used by the @test-routes@ suite.+module Hierarchy.ResourceTree where++import Yesod.Routes.Parse+import Language.Haskell.TH (Type)+import Yesod.Routes.TH++data Hierarchy = Hierarchy++hierarchyResources :: [ResourceTree String]+hierarchyResources = [parseRoutes|+/ HomeR GET++----------------------------------------++/!#Int BackwardsR GET++/admin/#Int AdminR:+    /            AdminRootR GET+    /login       LoginR     GET POST+    /table/#Text TableR     GET++/nest/ NestR !NestingAttr:++  /spaces      SpacedR   GET !NonNested++  /nest2 Nest2:+    /           GetPostR  GET POST+    /get        Get2      GET+    /post       Post2         POST+    /nest-inner NestInner:+        /       NestInnerIndexR GET+-- lol++  /nest3 Nest3:+    /get        Get3      GET+    /post       Post3         POST+--    /#Int       Delete3            DELETE++/afterwards AfterR !parent !key=value1:+  /             After     GET !child !key=value2++|]++hierarchyResourcesWithType :: [ResourceTree Type]+hierarchyResourcesWithType = map (fmap parseType) hierarchyResources
+ test/Route/DeepAritySpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Exercises the reify/'typeArity' path that 'assertNestedSubArity' runs+-- inside 'mkNestedDispatchInstanceWith'\'s recursion — the part the pure+-- 'checkNestedSubArity' unit tests in "Route.SubDispatchAritySpec" can't reach.+-- A 2nd-level-or-deeper nested datatype whose arity doesn't match the site's+-- type-argument count must be caught by the guard's @fail@ (an actionable+-- 'ArityMismatch') rather than slip through to a cryptic kind error in+-- generated code.+module Route.DeepAritySpec (spec) where++import Test.Hspec+import Language.Haskell.TH (recover)+import Yesod.Routes.TH.Internal+    ( assertNestedSubArity+    , resolveRouteCon+    , typeArity+    , ArityCallSite(..)+    , SubsiteName(..)+    , SubsiteArity(..)+    )+import Route.DeepArityTypes (ParamSite, MatchingDeepR, WrongDeepR)++-- | The reified arities feeding the guard, extracted at compile time through+-- the same 'typeArity' call 'assertNestedSubArity' makes.+reifiedArities :: (Int, Int, Int)+reifiedArities =+    $(do+        a <- typeArity ''ParamSite+        b <- typeArity ''MatchingDeepR+        c <- typeArity ''WrongDeepR+        [| (a, b, c) |])++-- | 'True' iff the arity guard fired its @fail@ for a (site arity 1) vs.+-- (@WrongDeepR@ arity 0) pairing — i.e. the deep mismatch was caught at the+-- guard rather than escaping into ill-kinded generated code.+wrongArityCaught :: Bool+wrongArityCaught =+    $(do+        rc <- resolveRouteCon "WrongDeepR"+        recover [| True |] $ do+            assertNestedSubArity TopLevelCall (SubsiteName "ParamSite") (SubsiteArity 1) rc+            [| False |])++-- | 'True' iff a matching (arity 1 vs. 1) pairing passes the guard cleanly.+matchingArityOk :: Bool+matchingArityOk =+    $(do+        rc <- resolveRouteCon "MatchingDeepR"+        recover [| False |] $ do+            assertNestedSubArity TopLevelCall (SubsiteName "ParamSite") (SubsiteArity 1) rc+            [| True |])++spec :: Spec+spec = describe "deep nested-route arity guard (reify path)" $ do+    it "reifies datatype arities used by the guard" $+        reifiedArities `shouldBe` (1, 1, 0)+    it "catches a deep arity mismatch with the actionable guard (not a kind error)" $+        wrongArityCaught `shouldBe` True+    it "lets a correctly-parameterized deep nested datatype through" $+        matchingArityOk `shouldBe` True
+ test/Route/DeepArityTypes.hs view
@@ -0,0 +1,15 @@+-- | Datatypes for "Route.DeepAritySpec", in their own module so the spec's+-- compile-time splices can 'reify' them — a datatype defined in the same module+-- as a top-level splice is not yet in the type environment at a 'reify'.+module Route.DeepArityTypes+    ( ParamSite (..)+    , MatchingDeepR (..)+    , WrongDeepR (..)+    ) where++-- A parameterized site (arity 1) plus two candidate nested datatypes: one whose+-- arity matches (1) and one whose arity is wrong (0). These stand in for a+-- deeply-nested subroute reached by the dispatch recursion.+data ParamSite a = ParamSite+data MatchingDeepR a = MatchingDeepR+data WrongDeepR = WrongDeepR
+ test/Route/DiscoveryModeSpec.hs view
@@ -0,0 +1,49 @@+-- | Unit tests for the 'discoveryMode' classifier. It is a pure, total+-- function but previously had no direct coverage; every behavioural test only+-- exercised it indirectly through generated code.+module Route.DiscoveryModeSpec (spec) where++import Test.Hspec+import Yesod.Routes.TH.RenderRoute+    ( defaultOpts+    , setParameterizedSubroute+    , setFocusOnNestedRoute+    , DiscoveryMode (..)+    , discoveryMode+    )+import Yesod.Routes.TH.Types (TyArgs, toTyArgs)+import Language.Haskell.TH (Type (ConT), mkName)++-- | A site with no type parameters ('hasTyArgs' 'False').+noArgs :: TyArgs+noArgs = toTyArgs []++-- | A site with one type parameter ('hasTyArgs' 'True').+someArgs :: TyArgs+someArgs = toTyArgs [(ConT (mkName "Int"), mkName "a")]++spec :: Spec+spec = describe "discoveryMode" $ do+    -- Dimension 1: no type args (a monomorphic site is always nested).+    it "is NestedDiscovery for a monomorphic site, even with all opts off" $+        discoveryMode defaultOpts noArgs `shouldBe` NestedDiscovery++    -- Dimensions 2/3 off, has type args: the backwards-compatible inline case.+    it "is InlineCompat for a parameterized site with default opts" $+        discoveryMode defaultOpts someArgs `shouldBe` InlineCompat++    -- Dimension 2: roParameterizedSubroute in the parameterized case.+    it "is NestedDiscovery for a parameterized site when parameterized-subroute is set" $+        discoveryMode (setParameterizedSubroute True defaultOpts) someArgs+            `shouldBe` NestedDiscovery++    -- Dimension 3: roFocusOnNestedRoute in the parameterized case.+    it "is NestedDiscovery for a parameterized site when focusing on a nested route" $+        discoveryMode (setFocusOnNestedRoute "Target" defaultOpts) someArgs+            `shouldBe` NestedDiscovery++    it "stays NestedDiscovery for a monomorphic site with the flags set" $ do+        discoveryMode (setParameterizedSubroute True defaultOpts) noArgs+            `shouldBe` NestedDiscovery+        discoveryMode (setFocusOnNestedRoute "Target" defaultOpts) noArgs+            `shouldBe` NestedDiscovery
+ test/Route/FallthroughSpec.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns#-}+++-- | The nested-route fallthrough contract for a top-level site, generated with+-- @setNestedRouteFallthrough True@. Two same-prefix parents share @\/foo@+-- (@FirstFooR@ index-only, @SecondFooR@ with deeper children). With fallthrough+-- on, a request missing inside @FirstFooR@ continues to the sibling rather than+-- committing. Asserts at both layers: @parseRoute@ falls through to the right+-- constructor, and a WAI dispatch round-trip (via 'YesodCoreTest.RuntimeHarness')+-- serves the expected handler.+module Route.FallthroughSpec where++import Network.Wai+import Yesod.Core+import Test.Hspec+import Data.ByteString.Lazy (ByteString)++import YesodCoreTest.RuntimeHarness (assertRequestRaw)++data App = App++do+    let resources = [parseRoutesNoCheck|++/ HomeR+/foo FirstFooR:+    /   FooIndexR+/foo SecondFooR:+    /blah FooBlahR+    /baz  FooBaz1R:+        /   FooBazIndexR+    /baz    FooBaz2R:+        /foo    FooBaz2FooR++    |]++    let opts = setNestedRouteFallthrough True defaultOpts+    mkYesodOpts opts "App" resources++instance Yesod App where+    messageLoggerSource = mempty++handleFooBlahR :: HandlerFor site String+handleFooBlahR = pure "FooBlahR"++handleHomeR :: HandlerFor site String+handleHomeR = pure "HomeR"++handleFooBaz2FooR :: HandlerFor site String+handleFooBaz2FooR = pure "FooBaz2FooR"++handleFooBazIndexR :: HandlerFor site String+handleFooBazIndexR = pure "FooBazIndexR"++handleFooIndexR :: HandlerFor site String+handleFooIndexR = pure "FooIndexR"++spec :: Spec+spec = do+    describe "parseRoute" $ do+        let routeShouldParse path result =+                parseRoute (path, []) `shouldBe` Just result+            routeShouldNotParse path =+                parseRoute (path, []) `shouldBe` (Nothing :: Maybe (Route App))+        it "matches the first parent without falling through" $ do+            routeShouldParse ["foo"] (FirstFooR FooIndexR)+        it "can fall through" $ do+            routeShouldParse ["foo", "blah"] (SecondFooR FooBlahR)+        it "nested fallthrough works too" $ do+            routeShouldParse ["foo", "baz", "foo"] (SecondFooR (FooBaz2R FooBaz2FooR))+        it "can fail" $ do+            routeShouldNotParse ["asdf"]++    describe "Dispatch" $ do+        it "/" $ do+            testRequestIO+                200+                defaultRequest+                    { pathInfo = []+                    }+                (Just "HomeR")+        it "/foo" $ do+            testRequestIO+                200+                defaultRequest+                    { pathInfo = ["foo"]+                    }+                (Just "FooIndexR")++testRequestIO :: HasCallStack => Int -- ^ http status code+            -> Request+            -> Maybe ByteString -- ^ expected body+            -> IO ()+testRequestIO status req mexpected =+    assertRequestRaw (toWaiApp App) req status mexpected
+ test/Route/FocusLeafConsSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell #-}+-- | This module pins the constructor set of the generated @FocusNestR@+-- datatype exactly, so escalate an incomplete 'describeFocus' to an error.+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Regression test for 'mkRouteConsOpts' in focus (module-split) mode.+--+-- Previously the focused branch dropped every 'ResourceLeaf' among the+-- target's children (returning @([], [])@ for leaves), so the focused+-- datatype was generated without its leaf constructors. Here we splice a+-- datatype built directly from 'mkRouteConsOpts'' focused output, then assert+-- its constructor set is /exactly/ what we expect via a total 'case':+--+--   * a /missing/ constructor fails the pattern reference (a name that isn't+--     in scope), and+--   * an /extra/ constructor makes 'describeFocus' non-exhaustive, which+--     @-Werror=incomplete-patterns@ (set above) turns into a compile error.+--+-- So this module fails to build unless @FocusNestR@ has precisely the two leaf+-- constructors @FocusIndexR@ and @FocusShowR Int@.+module Route.FocusLeafConsSpec (spec) where++import Test.Hspec+import Language.Haskell.TH+import Yesod.Routes.TH.Types+import Yesod.Routes.TH.RenderRoute+    ( mkRouteConsOpts+    , defaultOpts+    , setFocusOnNestedRoute+    )++data App = App++-- | A nested route @FocusNestR@ whose children are two leaves. We build the+-- focused datatype from 'mkRouteConsOpts' and declare it by hand from the+-- returned constructors.+$(do+    let leaf name pieces =+            ResourceLeaf (Resource name pieces (Methods Nothing ["GET"]) [] True)+        parent name pieces =+            ResourceParent name True mempty pieces+        routes =+            [ leaf "FocusHomeR" []+            , parent "FocusNestR" []+                [ leaf "FocusIndexR" []+                , leaf "FocusShowR" [Dynamic (ConT ''Int)]+                ]+            ]+    (cons, _decs) <-+        mkRouteConsOpts+            (setFocusOnNestedRoute "FocusNestR" defaultOpts)+            []+            NoTyArgs+            (ConT ''App)+            routes+    pure [DataD [] (mkName "FocusNestR") [] Nothing cons [DerivClause Nothing [ConT ''Show]]])++-- | Total over every constructor of the generated @FocusNestR@. Naming each+-- constructor exactly once is what makes this a complete-set assertion: see+-- the module header for how missing/extra constructors are each rejected at+-- compile time.+describeFocus :: FocusNestR -> String+describeFocus r = case r of+    FocusIndexR  -> "FocusIndexR"+    FocusShowR n -> "FocusShowR " ++ show n++spec :: Spec+spec = describe "mkRouteConsOpts (focus mode)" $+    it "generates exactly the focused route's leaf constructors" $ do+        -- The real assertion is at compile time (see 'describeFocus'); these+        -- just exercise the generated constructors.+        describeFocus FocusIndexR    `shouldBe` "FocusIndexR"+        describeFocus (FocusShowR 7) `shouldBe` "FocusShowR 7"
+ test/Route/InlineParseClausesSpec.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++-- | Unit tests for 'buildInlineParseClauses', the pure (effect-free) core of+-- the backwards-compatible inline @parseRoute@ codegen. Because it is pure —+-- it takes a deterministic fresh-name supply instead of 'Q'\'s 'newName' and+-- builds AST directly rather than through quotation brackets — its '[Clause]'+-- output can be asserted on directly, with no splicing, compilation, or+-- 'runQ'. This is the testability win from extracting the pure builder out of+-- 'generateParseRouteClausesInline'.+module Route.InlineParseClausesSpec (spec) where++import Test.Hspec+import Data.Maybe (catMaybes)+import Language.Haskell.TH+import Web.PathPieces (fromPathPiece)+import Yesod.Routes.TH.Types+import Yesod.Routes.TH.ParseRoute (buildInlineParseClauses)+import Route.PureQ (runPureQ)++-- | Run the pure builder at the top level (no wrapping), the way+-- 'generateParseRouteClausesInline' invokes it.+run :: ResourceTree Type -> [Clause]+run t = runPureQ (buildInlineParseClauses id t)++leaf :: String -> [Piece Type] -> Dispatch Type -> ResourceTree Type+leaf name pieces d = ResourceLeaf (Resource name pieces d [] True)++methods :: [String] -> Dispatch Type+methods = Methods Nothing++parent :: String -> [Piece Type] -> [ResourceTree Type] -> ResourceTree Type+parent name pieces = ResourceParent name True mempty pieces++-- | Assert there is exactly one clause and hand it to the continuation.+withOnlyClause :: [Clause] -> (Clause -> Expectation) -> Expectation+withOnlyClause cs k =+    case cs of+        [c] -> k c+        _   -> expectationFailure $ "expected exactly one clause, got " <> show (length cs)++-- | Variables bound by a @fromPathPiece@ view pattern, descending through the+-- list\/tuple\/constructor patterns the inline builder nests them in.+boundDynVars :: Pat -> [Name]+boundDynVars (ViewP (VarE f) inner)+    | f == 'fromPathPiece = simpleVars inner+boundDynVars p = concatMap boundDynVars (subPats p)++-- | Plain 'VarP' names anywhere within a pattern.+simpleVars :: Pat -> [Name]+simpleVars (VarP n) = [n]+simpleVars p        = concatMap simpleVars (subPats p)++-- | The immediate sub-patterns of a pattern (only the shapes the inline+-- builder produces need handling).+subPats :: Pat -> [Pat]+subPats (TupP ps)     = ps+subPats (ListP ps)    = ps+subPats (ViewP _ p)   = [p]+subPats (ParensP p)   = [p]+subPats (BangP p)     = [p]+subPats (TildeP p)    = [p]+subPats (AsP _ p)     = [p]+subPats (SigP p _)    = [p]+#if MIN_VERSION_template_haskell(2,18,0)+subPats (ConP _ _ ps) = ps+#else+subPats (ConP _ ps)   = ps+#endif+subPats _             = []++-- | The variables referenced in an expression.+usedVars :: Exp -> [Name]+usedVars (VarE n) = [n]+usedVars e        = concatMap usedVars (subExps e)++-- | The match alternatives of the top-level expression, when it is a @case@+-- (the shape a parent's committing clause produces). 'Nothing' otherwise.+caseMatches :: Exp -> Maybe [Match]+caseMatches (CaseE _ ms) = Just ms+caseMatches _            = Nothing++-- | The body expression of a clause that has no @where@ bindings.+clauseExp :: Clause -> Exp+clauseExp (Clause _ body _) = clauseBodyExp body++-- | Whether a match alternative is the catch-all @_ -> Nothing@ fallback.+isNothingFallback :: Match -> Bool+isNothingFallback (Match WildP (NormalB (ConE n)) []) = n == 'Nothing+isNothingFallback _                                    = False++-- | The immediate sub-expressions of an expression.+subExps :: Exp -> [Exp]+subExps (AppE a b)       = [a, b]+subExps (AppTypeE e _)   = [e]+subExps (InfixE ma _ mb) = catMaybes [ma, mb]+subExps (UInfixE a b c)  = [a, b, c]+subExps (ParensE e)      = [e]+subExps (LamE _ e)       = [e]+subExps (SigE e _)       = [e]+subExps (CondE a b c)    = [a, b, c]+subExps (CaseE e ms)     = e : [me | Match _ (NormalB me) _ <- ms]+subExps (ListE es)       = es+#if MIN_VERSION_template_haskell(2,16,0)+subExps (TupE mes)       = catMaybes mes+#else+subExps (TupE es)        = es+#endif+subExps _                = []++-- | The expression in a clause body (the inline builder emits 'NormalB' for+-- leaves and a single-guard 'GuardedB' under fallthrough).+clauseBodyExp :: Body -> Exp+clauseBodyExp (NormalB e)             = e+clauseBodyExp (GuardedB ((_, e) : _)) = e+-- Total on the (unreached) empty-guard case: a var-free sentinel so a stray+-- input fails an assertion locally instead of aborting the whole spec run.+clauseBodyExp (GuardedB [])           = ConE '()++spec :: Spec+spec = describe "buildInlineParseClauses (pure inline parseRoute codegen)" $ do+    it "produces one clause for a single static leaf" $+        length (run (leaf "HomeR" [Static "home"] (methods ["GET"]))) `shouldBe` 1++    it "emits exactly one (committing) clause per parent, matching its prefix once" $ do+        -- 1.6 semantics: the parent contributes ONE top-level clause that+        -- matches the parent prefix, then cases over its children. It does not+        -- expand to one flat clause per descendant leaf (which would re-parse+        -- the prefix and let a child miss fall through to a sibling route).+        let tree = parent "AdminR" [Static "admin"]+                [ leaf "UsersR" [Static "users"] (methods ["GET"])+                , leaf "PostsR" [Static "posts"] (methods ["GET"])+                ]+        withOnlyClause (run tree) $ \c ->+            case caseMatches (clauseExp c) of+                Nothing -> expectationFailure "expected the parent clause body to be a case over children"+                -- two children + the committing Nothing fallback+                Just ms -> length ms `shouldBe` 3++    it "ends the parent's case with a Nothing fallback (commit-on-parent-prefix)" $ do+        -- This is the heart of the backwards-compat fix: once the parent prefix+        -- matches, a child miss must resolve to 'Nothing' (a 404 that agrees+        -- with dispatch), NOT fall through to a later top-level route.+        let tree = parent "AdminR" [Static "admin"]+                [ leaf "UsersR" [Static "users"] (methods ["GET"]) ]+        withOnlyClause (run tree) $ \c ->+            case caseMatches (clauseExp c) of+                Nothing -> expectationFailure "expected the parent clause body to be a case over children"+                Just ms -> case reverse ms of+                    (lastM : _) -> isNothingFallback lastM `shouldBe` True+                    []          -> expectationFailure "expected at least the Nothing fallback"++    it "commits at each level for deeply-nested parents (nested cases, each Nothing-terminated)" $ do+        let tree = parent "AR" [Static "a"]+                [ parent "BR" [Static "b"]+                    [ leaf "CR" [Static "c"] (methods ["GET"])+                    , leaf "DR" [Static "d"] (methods ["GET"])+                    ]+                ]+        -- One top-level clause for AR; its case has one child match (BR's+        -- committing clause-as-match) plus the Nothing fallback.+        withOnlyClause (run tree) $ \c ->+            case caseMatches (clauseExp c) of+                Nothing -> expectationFailure "expected AR's body to be a case"+                Just msA -> do+                    length msA `shouldBe` 2+                    isNothingFallback (last msA) `shouldBe` True+                    -- The non-fallback alternative is BR's committing match,+                    -- whose body is itself a case (over CR/DR) ending in Nothing.+                    case msA of+                        (Match _ (NormalB innerE) [] : _) ->+                            case caseMatches innerE of+                                Nothing  -> expectationFailure "expected BR's body to be a case"+                                Just msB -> do+                                    length msB `shouldBe` 3 -- CR, DR, Nothing+                                    isNothingFallback (last msB) `shouldBe` True+                        _ -> expectationFailure "unexpected shape for BR's match alternative"++    it "binds a dynamic piece with a fromPathPiece view pattern" $+        withOnlyClause (run (leaf "UserR" [Static "user", Dynamic (ConT ''Int)] (methods ["GET"]))) $ \c ->+            pprint c `shouldContain` "fromPathPiece"++    it "uses fromPathMultiPiece for a multipiece leaf" $+        withOnlyClause (run (leaf "FilesR" [Static "files"] (Methods (Just (ConT ''String)) ["GET"]))) $ \c ->+            pprint c `shouldContain` "fromPathMultiPiece"++    it "delegates a subsite leaf through parseRoute" $+        withOnlyClause (run (leaf "SubR" [Static "sub"] (Subsite (ConT (mkName "SubSite")) "getSub"))) $ \c ->+            pprint c `shouldContain` "parseRoute"++    it "prefixes accumulated parent pieces onto each descendant clause" $ do+        -- The parent's static piece must appear in the (single) child clause,+        -- alongside the child's own piece — that is what \"inline\" means.+        let tree = parent "OrgR" [Static "org", Dynamic (ConT ''Int)]+                [ leaf "TeamR" [Static "team"] (methods ["GET"]) ]+        withOnlyClause (run tree) $ \c -> do+            pprint c `shouldContain` "org"+            pprint c `shouldContain` "team"++    it "threads the parent's dynamic binder into the reconstructed route body" $ do+        -- A parent with a dynamic piece: its binder must be matched in the path+        -- pattern (via 'fromPathPiece') *and* fed back into the reconstructed+        -- route in the body. That threading — not merely that the pieces show+        -- up textually — is the property the inline arm has to preserve.+        let tree = parent "OrgR" [Static "org", Dynamic (ConT ''Int)]+                [ leaf "TeamR" [Static "team"] (methods ["GET"]) ]+        withOnlyClause (run tree) $ \(Clause pats body _) -> do+            let dynVars = concatMap boundDynVars pats+                used    = usedVars (clauseBodyExp body)+            -- Exactly one dynamic piece (the parent's, bound via fromPathPiece)+            -- and it is referenced in the reconstructed body — i.e. one 'True'.+            -- Empty dynVars gives @[] /= [True]@, so this never passes vacuously.+            map (`elem` used) dynVars `shouldBe` [True]
+ test/Route/InstanceProbeSpec.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Pins the answer to: /can 'isInstance' fail if the route datatype's+-- type parameters remain abstract?/ ('nestedInstanceExists'+-- saturates a resolved datatype with fresh, unannotated 'VarT's via+-- 'fullyApplyType' rather than ground types.)+--+-- The exercised contract:+--+--   * Saturation to the datatype's /own/ reified arity keeps the probed head+--     well-kinded, so the probe is a total query — \"could any instance+--     match\" — that returns 'True'\/'False' but never aborts the splice.+--   * It holds even when a parameter is higher-kinded (@(f :: Type -> Type)@):+--     the bare @VarT@ 'fullyApplyType' supplies has its kind inferred from the+--     datatype's declared kind, so the head is still well-kinded.+--   * The arity-0 case (no parameters) degenerates to probing the bare+--     constructor.+--+-- Each probe runs inside a compile-time splice wrapped in 'recover': if+-- 'isInstance' ever threw (the failure mode guarded against here), the+-- splice would fall through to the 'recover' handler, which 'error's, and the+-- expectation would fail loudly rather than silently.+module Route.InstanceProbeSpec (spec) where++import Test.Hspec+import Language.Haskell.TH (recover, isInstance, Type (ConT, AppT))+import Yesod.Routes.TH.Internal (nestedInstanceExists, resolveRouteCon)+import Route.InstanceProbeTypes+    ( Probe, HasInst, HasInst2, HasInstInt, NoInst, HK, HKInst, Mono+    , ProbePoly, PolyFull, PolyUnapplied, PolyPartial+    )++spec :: Spec+spec = describe "nestedInstanceExists / fullyApplyType abstract-parameter probe" $ do+    it "returns True for an arity-1 datatype that has an instance" $+        $(do+            rc <- resolveRouteCon "HasInst"+            recover [| error "isInstance crashed on HasInst" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    it "returns True for an arity-2 datatype with an instance at abstract parameters" $+        $(do+            rc <- resolveRouteCon "HasInst2"+            recover [| error "isInstance crashed on HasInst2" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    -- Whether probing the abstract head @HasInstInt a@ finds the concrete+    -- @instance Probe (HasInstInt Int)@ depends on the GHC version: GHC 9.0++    -- 'reifyInstances' returns unifiers (so a bare type variable in the query+    -- unifies with @Int@ and the probe reports 'True'), whereas GHC < 9.0 does+    -- not return the concrete-argument instance for a type-variable query head+    -- (so it reports 'False'). This concrete-argument shape never arises in real+    -- codegen — nested-discovery instances are always emitted at fully-abstract+    -- parameters (the 'HasInst' case above), which every supported GHC resolves+    -- identically — so this case only pins the observed 'reifyInstances'+    -- divergence, not a behaviour the codegen relies on.+#if __GLASGOW_HASKELL__ >= 900+    it "returns True when the only instance is at a concrete argument (a unifier counts as could-match)" $+        $(do+            rc <- resolveRouteCon "HasInstInt"+            recover [| error "isInstance crashed on HasInstInt" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True+#else+    it "returns False when the only instance is at a concrete argument (GHC < 9.0 reifyInstances does not unify a type-variable query head)" $+        $(do+            rc <- resolveRouteCon "HasInstInt"+            recover [| error "isInstance crashed on HasInstInt" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` False+#endif++    it "returns False for an arity-1 datatype with no instance" $+        $(do+            rc <- resolveRouteCon "NoInst"+            recover [| error "isInstance crashed on NoInst" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` False++    it "does not crash on a higher-kinded (f :: Type -> Type) parameter with no instance (returns False)" $+        $(do+            rc <- resolveRouteCon "HK"+            recover [| error "isInstance crashed on HK" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` False++    it "does not crash on a higher-kinded parameter with an instance (returns True)" $+        $(do+            rc <- resolveRouteCon "HKInst"+            recover [| error "isInstance crashed on HKInst" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    it "handles the zero-arity case (bare constructor head) with an instance" $+        $(do+            rc <- resolveRouteCon "Mono"+            recover [| error "isInstance crashed on Mono" |] $ do+                b <- nestedInstanceExists ''Probe rc+                [| b |]) `shouldBe` True++    -- Poly-kinded class: lets us represent (and so probe) instances whose head+    -- is not fully applied — the shapes a 'Type'-kinded class rejects outright.+    it "ProbePoly: returns True for an instance at the fully-applied head" $+        $(do+            rc <- resolveRouteCon "PolyFull"+            recover [| error "isInstance crashed on PolyFull" |] $ do+                b <- nestedInstanceExists ''ProbePoly rc+                [| b |]) `shouldBe` True++    it "ProbePoly: returns False when the only instance is at the unapplied constructor (the arity-saturated probe head doesn't match it)" $+        $(do+            rc <- resolveRouteCon "PolyUnapplied"+            recover [| error "isInstance crashed on PolyUnapplied" |] $ do+                b <- nestedInstanceExists ''ProbePoly rc+                [| b |]) `shouldBe` False++    it "ProbePoly: returns False when the only instance is at a partially-applied head" $+        $(do+            rc <- resolveRouteCon "PolyPartial"+            recover [| error "isInstance crashed on PolyPartial" |] $ do+                b <- nestedInstanceExists ''ProbePoly rc+                [| b |]) `shouldBe` False++    -- Why 'nestedInstanceExists' must saturate to the datatype's *full* arity:+    -- the partial instance @ProbePoly (PolyPartial a)@ matches *any* one-argument+    -- application of @PolyPartial@. Probing one argument short — at @PolyPartial+    -- Int@ (kind Type -> Type) — therefore matches it, while the full-arity head+    -- @PolyPartial a b@ (kind Type, what the probe actually uses) does not. So a+    -- probe that stopped short would be spuriously fooled by a partial instance;+    -- saturating fully is what avoids that. These pin that matching boundary by+    -- calling 'isInstance' directly at hand-built heads.+    it "isInstance matches the partial instance one argument short (PolyPartial Int)" $+        $(do+            recover [| error "isInstance crashed on PolyPartial Int" |] $ do+                b <- isInstance ''ProbePoly [ConT ''PolyPartial `AppT` ConT ''Int]+                [| b |]) `shouldBe` True++    it "isInstance does not match the partial instance at the full application (PolyPartial Int Int)" $+        $(do+            recover [| error "isInstance crashed on PolyPartial Int Int" |] $ do+                b <- isInstance ''ProbePoly [ConT ''PolyPartial `AppT` ConT ''Int `AppT` ConT ''Int]+                [| b |]) `shouldBe` False++    it "isInstance does not match the unapplied-constructor instance once an argument is applied (PolyUnapplied Int)" $+        $(do+            recover [| error "isInstance crashed on PolyUnapplied Int" |] $ do+                b <- isInstance ''ProbePoly [ConT ''PolyUnapplied `AppT` ConT ''Int]+                [| b |]) `shouldBe` False
+ test/Route/InstanceProbeTypes.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}++-- | Datatypes and a stand-in probe class for "Route.InstanceProbeSpec", in+-- their own module so the spec's compile-time splices can 'reify' them — a+-- datatype defined in the same module as a top-level splice is not yet in the+-- type environment at a 'reify' (the same reason "Route.DeepArityTypes" is+-- separate).+--+-- 'Probe' stands in for any of the real nested-discovery classes+-- (@YesodDispatchNested@, @RenderRouteNested@, …) that 'nestedInstanceExists'+-- probes: those classes aren't visible to the pure @test-routes@ suite, but+-- 'nestedInstanceExists' only ever asks @isInstance klass [head]@, so any+-- single-parameter class with the right instance shape exercises the same+-- code path.+module Route.InstanceProbeTypes+    ( Probe+    , HasInst (..)+    , HasInst2 (..)+    , HasInstInt (..)+    , NoInst (..)+    , HK (..)+    , HKInst (..)+    , Mono (..)+      -- * Poly-kinded probe (under-applied instance heads)+    , ProbePoly+    , PolyFull (..)+    , PolyUnapplied (..)+    , PolyPartial (..)+    ) where++import Data.Kind (Type)++-- | A single-parameter probe class, standing in for the nested-discovery+-- classes 'nestedInstanceExists' checks against.+class Probe a++-- | Arity-1, kind-'Type' parameter, /with/ a @Probe@ instance — the probe must+-- answer 'True'. The instance is given at a fully abstract parameter, exactly+-- as our codegen emits per-route-datatype instances.+data HasInst a = HasInst+instance Probe (HasInst a)++-- | Arity-2: 'fullyApplyType' must saturate with /two/ fresh 'VarT's before+-- the head is well-kinded. With an instance at fully abstract parameters the+-- probe answers 'True'.+data HasInst2 a b = HasInst2+instance Probe (HasInst2 a b)++-- | Arity-1 whose only instance is at a /concrete/ argument. The probe asks+-- \"could any instance match\". On GHC 9.0+ 'reifyInstances' returns unifiers+-- (not just exact matches), so probing the abstract @HasInstInt a@ finds the+-- @Int@ instance and answers 'True'; on GHC < 9.0 'reifyInstances' does not+-- unify a bare type-variable query head against the concrete instance, so it+-- answers 'False'. (Real codegen never emits instances at concrete arguments,+-- so this divergence does not affect nested discovery; see the matching test in+-- "Route.InstanceProbeSpec".)+--+-- (Instances at an /under-applied/ constructor — the bare @instance Probe+-- HasInstInt@, or an arity-2 datatype applied to one argument like+-- @instance Probe (HasInst2 a)@ — can't be written against this 'Type'-kinded+-- 'Probe': a head of kind @Type -> Type@ is kind-rejected at its definition+-- site (GHC: \"Expecting one more argument to …; Expected a type, but … has+-- kind @* -> *@\"). To probe those shapes at all they must be made+-- representable by a /poly-kinded/ class; see 'ProbePoly' below.)+data HasInstInt a = HasInstInt+instance Probe (HasInstInt Int)++-- | Arity-1, kind-'Type' parameter, /without/ a @Probe@ instance — the probe+-- must answer 'False'.+data NoInst a = NoInst++-- | Arity-1 with a kind-annotated, non-'Type' parameter @(f :: Type -> Type)@+-- and /no/ instance. The point of this case: 'fullyApplyType' saturates @HK@+-- with a bare, unannotated @VarT@ whose kind GHC must infer from @HK@'s+-- declared kind. The probe must not crash and must report 'False'.+data HK (f :: Type -> Type) = HK++-- | As 'HK', but /with/ an instance given at an abstract higher-kinded+-- parameter. The probe must report 'True' without crashing.+data HKInst (f :: Type -> Type) = HKInst+instance Probe (HKInst f)++-- | Arity-0 (the zero type-parameter case): 'fullyApplyType' applies no+-- arguments, so the probed head is the bare constructor. With an instance the+-- probe answers 'True'.+data Mono = Mono+instance Probe Mono++-- | A /poly-kinded/ probe class. Unlike 'Probe' (kind @Type -> Constraint@),+-- @ProbePoly@ accepts a head of any kind, which makes the under-applied+-- instance shapes that 'Probe' rejects at their definition site representable —+-- so we can pin down what 'nestedInstanceExists' does when the only instance is+-- at such a head. The probe always saturates the datatype to its /own/ arity+-- (a kind-'Type' head; see 'fullyApplyType'), so these cases also confirm it+-- queries at the fully-applied head specifically.+class ProbePoly (a :: k)++-- | Poly-kinded class, instance at the /fully-applied/ head (kind 'Type').+-- Positive control: the probe saturates @PolyFull@ to @PolyFull a@ and matches.+data PolyFull a = PolyFull+instance ProbePoly (PolyFull a)++-- | Instance at the /unapplied/ arity-1 constructor (head kind @Type -> Type@),+-- representable only because 'ProbePoly' is poly-kinded. The probe saturates to+-- @PolyUnapplied a@ before querying, so the instance at the bare constructor is+-- a different head.+data PolyUnapplied a = PolyUnapplied+instance ProbePoly PolyUnapplied++-- | Instance at a /partially-applied/ arity-2 constructor (head kind+-- @Type -> Type@). As 'PolyUnapplied', the full-arity probe head+-- @PolyPartial a b@ is a different head from the partial instance @PolyPartial a@.+data PolyPartial a b = PolyPartial+instance ProbePoly (PolyPartial a)
+ test/Route/MissingFocusTargetSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Exercises the TH failure paths that fire when a 'setFocusOnNestedRoute'+-- target does not exist in the resource tree. Historically the 'ParseRoute'+-- and 'RouteAttrs' generators silently produced an always-'Nothing' \/+-- always-'mempty' nested instance for a bogus target, while the 'Dispatch' and+-- 'RenderRoute' generators correctly 'fail'ed. All four are now routed through+-- the shared 'findNestedRoute' lookup and 'fail' with the same message.+--+-- A 'Q' 'fail' raises its message through 'qReport' rather than carrying it in+-- the thrown value (so 'runQ' just reports @\"Q monad failure\"@), so — as in+-- "Route.DeepAritySpec" — we assert at compile time with 'recover': each+-- generator is run inside a splice against a nonexistent target and must take+-- its @fail@ path (driving 'recover' to its handler). The shared lookup that+-- produces the \"was not found in resources\" message is unit-tested directly+-- via 'findNestedRoute'.+module Route.MissingFocusTargetSpec (spec) where++import Test.Hspec+import Data.Maybe (isNothing)+import Language.Haskell.TH (recover)++import Yesod.Routes.TH.Types (resourceTreeName, TyArgs(NoTyArgs))+import Yesod.Routes.TH.ParseRoute (mkParseRouteInstanceFor)+import Yesod.Routes.TH.RouteAttrs (mkRouteAttrsInstanceFor)+import Yesod.Routes.TH.RenderRoute+    (mkRenderRouteInstanceOpts, defaultOpts, setFocusOnNestedRoute)+import Yesod.Routes.TH.Dispatch (mkDispatchInstance)+import Yesod.Routes.TH.Internal (findNestedRoute)+import Route.MissingFocusTargetTypes (sampleTree, bogusType, bogusName)++-- | 'True' iff the named generator 'fail'ed on the bogus focus target (i.e.+-- 'recover' fell through to its @True@ handler); 'False' if it wrongly produced+-- declarations. Each is forced at compile time so a regression to a silent+-- always-empty instance flips the corresponding boolean.++parseRouteFailed :: Bool+parseRouteFailed =+    $(recover [| True |] $ do+        _ <- mkParseRouteInstanceFor bogusName sampleTree+        [| False |])++routeAttrsFailed :: Bool+routeAttrsFailed =+    $(recover [| True |] $ do+        _ <- mkRouteAttrsInstanceFor [] bogusType bogusName sampleTree+        [| False |])++renderRouteFailed :: Bool+renderRouteFailed =+    $(recover [| True |] $ do+        _ <- mkRenderRouteInstanceOpts+                (setFocusOnNestedRoute bogusName defaultOpts)+                [] NoTyArgs bogusType sampleTree+        [| False |])++dispatchFailed :: Bool+dispatchFailed =+    $(recover [| True |] $ do+        _ <- mkDispatchInstance+                (setFocusOnNestedRoute bogusName defaultOpts)+                bogusType [] NoTyArgs pure sampleTree+        [| False |])++spec :: Spec+spec = describe "missing focus target" $ do+    describe "fails every nested generator (recover path)" $ do+        it "ParseRoute (mkParseRouteInstanceFor)" $+            parseRouteFailed `shouldBe` True+        it "RouteAttrs (mkRouteAttrsInstanceFor)" $+            routeAttrsFailed `shouldBe` True+        it "RenderRoute (mkRenderRouteInstanceOpts)" $+            renderRouteFailed `shouldBe` True+        it "Dispatch (mkDispatchInstance)" $+            dispatchFailed `shouldBe` True++    describe "shared lookup (findNestedRoute)" $ do+        it "returns Nothing for a target absent from the tree" $+            isNothing (findNestedRoute bogusName sampleTree)+                `shouldBe` True+        it "returns the subtree for a target present in the tree" $+            (fmap (map resourceTreeName . snd) (findNestedRoute "ParentR" sampleTree))+                `shouldBe` Just ["ChildR"]
+ test/Route/MissingFocusTargetTypes.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Shared fixtures for "Route.MissingFocusTargetSpec". The resource tree and+-- bogus type live here (a separate module) so that the spec can use them inside+-- top-level TH splices without tripping the GHC stage restriction.+module Route.MissingFocusTargetTypes+    ( sampleTree+    , bogusType+    , bogusName+    ) where++import Language.Haskell.TH.Syntax (Type(ConT), mkName)+import Yesod.Routes.TH.Types++-- A tiny tree with a single real nested parent ("ParentR"). The generators+-- under test are never handed that name; they get 'bogusName', which is absent.+sampleTree :: [ResourceTree Type]+sampleTree =+    [ ResourceParent "ParentR" True mempty [Static "parent"]+        [ ResourceLeaf $+            Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True+        ]+    ]++bogusName :: String+bogusName = "DefinitelyNotARealRouteR"++bogusType :: Type+bogusType = ConT (mkName bogusName)
+ test/Route/NestedParseClausesSpec.hs view
@@ -0,0 +1,61 @@+-- | Unit tests for 'generateParseRouteClause' run in 'PureQ' — the+-- monad-polymorphic (over 'Quote') nested @parseRouteNested@ clause generator.+-- Production runs it in 'Q' (hygienic 'newName'); here we pin its name supply to+-- a deterministic counter so its 'Clause' output — and the set of parent names+-- it requests a 'ParseRouteNested' instance for — can be asserted directly, with+-- no splicing or 'runQ'. This is the payoff of hoisting the @isInstance@ query+-- out of the generator (see 'generateParseRouteClause').+module Route.NestedParseClausesSpec (spec) where++import Test.Hspec+import Control.Monad.State.Strict (runStateT)+import qualified Data.Set as Set+import Data.Set (Set)+import Language.Haskell.TH+import Yesod.Routes.TH.Types+import Yesod.Routes.TH.RenderRoute (defaultOpts)+import Yesod.Routes.TH.ParseRoute (generateParseRouteClause)+import Route.PureQ (runPureQ)++-- | Run the nested clause generator in 'PureQ': deterministic fresh names, pure+-- output. Returns the clause plus the set of parent names it requested a+-- 'ParseRouteNested' instance for.+run :: Set String -> ResourceTree Type -> (Clause, Set String)+run existing t =+    runPureQ $+        runStateT (generateParseRouteClause existing defaultOpts t) mempty++leaf :: String -> [Piece Type] -> Dispatch Type -> ResourceTree Type+leaf name pieces d = ResourceLeaf (Resource name pieces d [] True)++methods :: [String] -> Dispatch Type+methods = Methods Nothing++parent :: String -> [Piece Type] -> [ResourceTree Type] -> ResourceTree Type+parent name pieces = ResourceParent name True mempty pieces++fooParent :: ResourceTree Type+fooParent =+    parent "FooR" [Static "foo"]+        [ leaf "BarR" [Static "bar"] (methods ["GET"]) ]++spec :: Spec+spec = describe "generateParseRouteClause (nested parseRoute codegen in PureQ)" $ do+    it "records a parent that has no nested instance yet" $+        snd (run mempty fooParent) `shouldBe` Set.singleton "FooR"++    it "does not record a parent that already has a nested instance (hoisted query)" $+        snd (run (Set.singleton "FooR") fooParent) `shouldBe` mempty++    it "delegates a parent clause through parseRouteNested" $+        pprint (fst (run mempty fooParent)) `shouldContain` "parseRouteNested"++    it "records nothing for a bare leaf" $+        snd (run mempty (leaf "BarR" [Static "bar"] (methods ["GET"]))) `shouldBe` mempty++    it "is reproducible: re-running the same tree yields an identical clause (names and all)" $+        -- The PureQ counter resets to 0 each run, so the deterministic binders+        -- make the whole Clause '=='. Under Q's 'newName' the uniques would+        -- differ between runs — this equality is exactly what going through the+        -- pure 'Quote' instance buys the tests.+        run mempty fooParent `shouldBe` run mempty fooParent
+ test/Route/PureQ.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | A pure 'Quote' instance for unit-testing the TH clause builders without+-- 'Q'. The builders are monad-polymorphic over 'Quote' (their only effect is+-- fresh-'Name' generation): production runs them in 'Q' for hygienic 'newName'+-- binders, while these tests run them in 'PureQ', where 'newName' is a+-- deterministic monotonic counter. That makes the generated '[Clause]' AST+-- fully determined and directly comparable — no splicing or 'runQ' needed.+--+-- The deterministic names use non-hygienic 'mkName', which is fine for+-- pure-inspection tests but would risk shadowing in real splices — hence+-- production stays on 'Q' and only the tests pin the builder's monad to 'PureQ'.+module Route.PureQ+    ( PureQ+    , runPureQ+    ) where++import Control.Monad.State.Strict (State, evalState, state)+import Language.Haskell.TH.Syntax (Name, mkName)+import Language.Haskell.TH.Syntax.Compat (Quote(..))++-- | A pure name supply: 'State' over a monotonic counter.+newtype PureQ a = PureQ (State Int a)+    deriving (Functor, Applicative, Monad)++-- | Run a 'PureQ' computation, starting the counter at @0@. Re-running the same+-- builder therefore yields an identical AST (binders and all).+runPureQ :: PureQ a -> a+runPureQ (PureQ s) = evalState s 0++-- | Each 'newName' yields a distinct 'mkName' from the counter, so the builder's+-- output is reproducible and comparable.+instance Quote PureQ where+    newName base = PureQ $ state $ \n -> (mkName (base ++ show n), n + 1)
+ test/Route/RenderRouteSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns#-}++-- | Behavioural spec for @renderRouteNested@ on a deeply-nested route tree.+-- Pins the contract that rendering a nested leaf reconstructs the /entire/ path+-- from the site root (parent pieces and captures included), not just the leaf's+-- own fragment — the caller supplies the ancestor captures as a tuple.+module Route.RenderRouteSpec where++import Yesod.Core+import Test.Hspec++data App = App++mkYesodData "App" [parseRoutes|++/foo/#Int   FooR:+    /   FooIndexR+    /bar/#String    FooBarR:+        /   FooBarIndexR+        /baz    FooBarBazR:+            /new    FooBarBazNewR+            /delete/#String FooBarBazDeleteR+            /get/#String    FooBarBazGetR++    |]++spec :: Spec+spec = do+    describe "renderRouteNested" $ do+        it "renders the entire route, not just end fragment" $ do+            renderRouteNested (3, "hello") (FooBarBazGetR "asdf")+                `shouldBe`+                    (["foo", "3", "bar", "hello", "baz", "get", "asdf"], [])
+ test/Route/RouteAttrSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Pure spec asserting that route attributes (@!x@) declared on a /nested+-- parent/ are captured in its flattened 'frParentDetails' (@pdAttrs@), not just+-- on leaves. Operates directly on the parsed 'ResourceTree' decision data — no+-- splicing or codegen — so it pins where in the flattened structure parent+-- attrs land.+module Route.RouteAttrSpec (spec) where++import Yesod.Core+import Test.Hspec+import Yesod.Routes.TH.Types+import Data.Set (Set)+import qualified Data.Set as Set++routeNoAttributes :: [ResourceTree String]+routeNoAttributes = [parseRoutes|+/one OneR:+  /two TwoR:+    /three ThreeR:+      /four FourR POST+  |]++routeWithAttributes :: [ResourceTree String]+routeWithAttributes = [parseRoutes|+/one OneR:+  /two TwoR !x !z:+    /three ThreeR !y:+      /four FourR POST+  |]++spec :: Spec+spec = do+    describe "route attrs present" $ do+        it "has no route attrs on parent" $ do+            let parentDetails = concat $ frParentDetails <$> flatten routeNoAttributes+            let attrs = (\detail -> (pdName detail, pdAttrs detail)) <$> parentDetails+            Set.fromList attrs+                `shouldBe`+                    Set.fromList +                        [ ("OneR", Set.empty)+                        , ("TwoR", Set.empty)+                        , ("ThreeR", Set.empty)+                        ]+        it "has route attrs on parent" $ do+            let parentDetails = concat $ frParentDetails <$> flatten routeWithAttributes+            let attrs = (\detail -> (pdName detail, pdAttrs detail)) <$> parentDetails+            Set.fromList attrs+                `shouldBe`+                    Set.fromList +                        [ ("OneR", Set.empty)+                        , ("TwoR", Set.fromList ["x", "z"])+                        , ("ThreeR", Set.singleton "y")+                        ]
+ test/Route/SubDispatchAritySpec.hs view
@@ -0,0 +1,78 @@+-- | Unit tests for 'checkNestedSubArity', the guard that gives+-- 'mkYesodSubDispatchInstance' an actionable error (instead of a cryptic kind+-- error) when a parameterized subsite is paired with unparameterized nested+-- route datatypes.+module Route.SubDispatchAritySpec (spec) where++import Test.Hspec+import Yesod.Routes.TH.Internal+    ( checkNestedSubArity+    , arityMismatchMessage+    , ArityCallSite(..)+    , ArityMismatch(..)+    , SubsiteName(..)+    , RouteName(..)+    , SubsiteArity(..)+    , RouteArity(..)+    )++-- | The newtype wrappers are positional noise in the tests; this names the+-- call the way the production caller does. 'Nothing' means the arities match;+-- 'Just' carries the rendered mismatch message (phrased for a 'SubsiteCall').+check :: String -> String -> Int -> Int -> Maybe String+check sub route subArgs routeArity =+    fmap (arityMismatchMessage SubsiteCall) $+        checkNestedSubArity+            (SubsiteName sub)+            (RouteName route)+            (SubsiteArity subArgs)+            (RouteArity routeArity)++spec :: Spec+spec = describe "checkNestedSubArity" $ do+    it "accepts a monomorphic subsite with an unparameterized nested datatype" $+        check "MySub" "NestedR" 0 0 `shouldBe` Nothing++    it "accepts a parameterized subsite whose nested datatype carries the param" $+        check "MySub" "NestedR" 1 1 `shouldBe` Nothing++    it "rejects when the nested datatype carries more params than the subsite" $+        -- Over-arity leaves the instance head partially applied (kind+        -- @Type -> ...@), so this must be rejected, not silently accepted.+        case check "MySub" "NestedR" 1 2 of+            Nothing -> expectationFailure "expected an arity mismatch"+            Just msg -> do+                msg `shouldContain` "`NestedR` has 2 type parameter(s)"+                msg `shouldContain` "the subsite `MySub` has 1"++    it "rejects a parameterized subsite with an unparameterized nested datatype" $+        check "MySub" "NestedR" 1 0 `shouldBe` Just+            (concat+                [ "mkYesodSubDispatchInstance: the nested route datatype "+                , "`NestedR` has 0 type parameter(s), but the subsite `MySub` "+                , "has 1. The subroute datatypes must carry exactly the "+                , "subsite's type parameter(s) \8212 generate the subsite's "+                , "routes with `mkYesodSubDataOpts (setParameterizedSubroute "+                , "True defaultOpts) ...` so a parameterized subsite gets "+                , "parameterized subroutes."+                ])++    it "names both types in the error message" $+        case check "MySub" "NestedR" 1 0 of+            Nothing -> expectationFailure "expected a mismatch"+            Just msg -> do+                msg `shouldContain` "MySub"+                msg `shouldContain` "NestedR"++    describe "arityMismatchMessage phrasing per call site" $ do+        let mismatch = ArityMismatch (SubsiteName "MySub") (RouteName "NestedR")+                                     (SubsiteArity 1) (RouteArity 0)+        it "names mkYesodSubDispatchInstance and calls it a subsite for a SubsiteCall" $ do+            let msg = arityMismatchMessage SubsiteCall mismatch+            msg `shouldContain` "mkYesodSubDispatchInstance"+            msg `shouldContain` "subsite"+        it "names mkYesod and calls it a site (not a subsite) for a TopLevelCall" $ do+            let msg = arityMismatchMessage TopLevelCall mismatch+            msg `shouldContain` "mkYesod:"+            msg `shouldNotContain` "subsite"+            msg `shouldContain` "site"
test/RouteSpec.hs view
@@ -1,29 +1,46 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns#-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -ddump-splices #-}+{-# LANGUAGE ViewPatterns#-}++-- | Entry point ('main') for the @test-routes@ suite — the pure-routing tests+-- that need no running site. Aggregates the @Route.*@ specs (fallthrough,+-- render, attrs, the pure decision/codegen specs, arity guards, focus-target+-- lookups, ...) and the @Hierarchy@ fixture, then adds inline RenderRoute /+-- route-parsing / overlap-checking / @parseRouteType@ checks below.+ import Test.Hspec import Test.HUnit ((@?=))-import Data.Text (Text, pack, unpack, singleton)+import Data.Text (Text) import Yesod.Routes.Class hiding (Route)-import qualified Yesod.Routes.Class as YRC-import Yesod.Routes.Parse (parseRoutesFile, parseRoutesNoCheck, parseTypeTree, TypeTree (..))+import Yesod.Routes.Parse (parseTypeTree, TypeTree (..))+import Yesod.Core import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch)-import Language.Haskell.TH.Syntax import Hierarchy-import qualified Data.ByteString.Char8 as S8 import qualified Data.Set as Set+import qualified Route.FallthroughSpec as FallthroughSpec+import qualified Route.RenderRouteSpec as RenderRouteSpec+import qualified YesodCoreTest.RenderRouteSpec as NestedRenderRouteSpec+import qualified Route.RouteAttrSpec as RouteAttrSpec+import qualified Route.DiscoveryModeSpec as DiscoveryModeSpec+import qualified Route.SubDispatchAritySpec as SubDispatchAritySpec+import qualified Route.DeepAritySpec as DeepAritySpec+import qualified Route.InstanceProbeSpec as InstanceProbeSpec+import qualified Route.InlineParseClausesSpec as InlineParseClausesSpec+import qualified Route.NestedParseClausesSpec as NestedParseClausesSpec+import qualified Route.FocusLeafConsSpec as FocusLeafConsSpec+import qualified Route.MissingFocusTargetSpec as MissingFocusTargetSpec+import qualified Data.Text as Text  data MyApp = MyApp @@ -46,188 +63,77 @@         Route         MySubParam = ParamRoute Char         deriving (Show, Eq, Read)-    renderRoute (ParamRoute x) = ([singleton x], [])+    renderRoute (ParamRoute x) = ([Text.singleton x], []) instance ParseRoute MySubParam where-    parseRoute ([unpack -> [x]], _) = Just $ ParamRoute x+    parseRoute ([Text.unpack -> [x]], _) = Just $ ParamRoute x     parseRoute _ = Nothing  getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam  do-    texts <- [t|[Text]|]+    texts <- pure "[Text]"     let resLeaves = map ResourceLeaf             [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"] True-            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] (Methods Nothing ["GET", "POST"]) [] True+            , Resource "BlogPostR" [Static "blog", Dynamic "Text"] (Methods Nothing ["GET", "POST"]) [] True             , Resource "WikiR" [Static "wiki"] (Methods (Just texts) []) [] True-            , Resource "SubsiteR" [Static "subsite"] (Subsite (ConT ''MySub) "getMySub") [] True-            , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] (Subsite (ConT ''MySubParam) "getMySubParam") [] True+            , Resource "SubsiteR" [Static "subsite"] (Subsite "MySub" "getMySub") [] True+            , Resource "SubparamR" [Static "subparam", Dynamic "Int"] (Subsite "MySubParam" "getMySubParam") [] True             ]         resParent = ResourceParent             "ParentR"             True+            mempty             [ Static "foo"-            , Dynamic $ ConT ''Text+            , Dynamic "Text"             ]             [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True             ]         ress = resParent : resLeaves-    rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress-    rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress-    prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress-    dispatch <- mkDispatchClause MkDispatchSettings-        { mdsRunHandler = [|runHandler|]-        , mdsSubDispatcher = [|subDispatch dispatcher|]-        , mdsGetPathInfo = [|fst|]-        , mdsMethod = [|snd|]-        , mdsSetPathInfo = [|\p (_, m) -> (p, m)|]-        , mds404 = [|pack "404"|]-        , mds405 = [|pack "405"|]-        , mdsGetHandler = defaultGetHandler-        , mdsUnwrapper = return-        } ress-    return-#if MIN_VERSION_template_haskell(2,11,0)-        $ InstanceD Nothing-#else-        $ InstanceD-#endif-            []-            (ConT ''Dispatcher-                `AppT` ConT ''MyApp-                `AppT` ConT ''MyApp)-            [FunD (mkName "dispatcher") [dispatch]]-        : prinst-        : rainst-        : rrinst+    mkYesod "MyApp" ress -instance Dispatcher MySub master where-    dispatcher env (pieces, _method) =-        ( pack $ "subsite: " ++ show pieces-        , Just $ envToMaster env route-        )-      where-        route = MySubRoute (pieces, [])+instance YesodSubDispatch MySub MyApp where+    yesodSubDispatch _yre = undefined -instance Dispatcher MySubParam master where-    dispatcher env (pieces, _method) =-        case map unpack pieces of-            [[c]] ->-                let route = ParamRoute c-                    toMaster = envToMaster env-                    MySubParam i = envSub env-                 in ( pack $ "subparam " ++ show i ++ ' ' : [c]-                    , Just $ toMaster route-                    )-            _ -> (pack "404", Nothing)+instance YesodSubDispatch MySubParam MyApp where+    yesodSubDispatch _yre = undefined -{--thDispatchAlias-    :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp)))-    => master-    -> sub-    -> (YRC.Route sub -> YRC.Route master)-    -> app -- ^ 404 page-    -> handler -- ^ 405 page-    -> Text -- ^ method-    -> [Text]-    -> app---thDispatchAlias = thDispatch-thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =-    case dispatch pieces0 of-        Just f -> f master sub toMaster app404 handler405 method0-        Nothing -> app404-  where-    dispatch = toDispatch-        [ Route [] False $ \pieces ->-            case pieces of-                [] -> do-                    Just $ \master' sub' toMaster' _app404' handler405' method ->-                        let handler =-                                case Map.lookup method methodsRootR of-                                    Just f -> f-                                    Nothing -> handler405'-                         in runHandler handler master' sub' RootR toMaster'-                _ -> error "Invariant violated"-        , Route [D.Static "blog", D.Dynamic] False $ \pieces ->-            case pieces of-                [_, x2] -> do-                    y2 <- fromPathPiece x2-                    Just $ \master' sub' toMaster' _app404' handler405' method ->-                        let handler =-                                case Map.lookup method methodsBlogPostR of-                                    Just f -> f y2-                                    Nothing -> handler405'-                         in runHandler handler master' sub' (BlogPostR y2) toMaster'-                _ -> error "Invariant violated"-        , Route [D.Static "wiki"] True $ \pieces ->-            case pieces of-                _:x2 -> do-                    y2 <- fromPathMultiPiece x2-                    Just $ \master' sub' toMaster' _app404' _handler405' _method ->-                        let handler = handleWikiR y2-                         in runHandler handler master' sub' (WikiR y2) toMaster'-                _ -> error "Invariant violated"-        , Route [D.Static "subsite"] True $ \pieces ->-            case pieces of-                _:x2 -> do-                    Just $ \master' sub' toMaster' app404' handler405' method ->-                        dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2-                _ -> error "Invariant violated"-        , Route [D.Static "subparam", D.Dynamic] True $ \pieces ->-            case pieces of-                _:x2:x3 -> do-                    y2 <- fromPathPiece x2-                    Just $ \master' sub' toMaster' app404' handler405' method ->-                        dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3-                _ -> error "Invariant violated"-        ]-    methodsRootR = Map.fromList [("GET", getRootR)]-    methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)]--}+instance Yesod MyApp where+    messageLoggerSource = mempty  main :: IO () main = hspec $ do+    describe "Route.FallthroughSpec" FallthroughSpec.spec+    describe "Route.RenderRouteSpec" RenderRouteSpec.spec+    describe "YesodCoreTest.RenderRouteSpec" NestedRenderRouteSpec.spec+    describe "Route.RouteAttrSpec" RouteAttrSpec.spec+    describe "Route.DiscoveryModeSpec" DiscoveryModeSpec.spec+    describe "Route.SubDispatchAritySpec" SubDispatchAritySpec.spec+    describe "Route.DeepAritySpec" DeepAritySpec.spec+    describe "Route.InstanceProbeSpec" InstanceProbeSpec.spec+    describe "Route.InlineParseClausesSpec" InlineParseClausesSpec.spec+    describe "Route.NestedParseClausesSpec" NestedParseClausesSpec.spec+    describe "Route.FocusLeafConsSpec" FocusLeafConsSpec.spec+    describe "Route.MissingFocusTargetSpec" MissingFocusTargetSpec.spec     describe "RenderRoute instance" $ do         it "renders root correctly" $ renderRoute RootR @?= ([], [])-        it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], [])-        it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], [])-        it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")]))-            @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")])+        it "renders blog post correctly" $ renderRoute (BlogPostR $ Text.pack "foo") @?= (map Text.pack ["blog", "foo"], [])+        it "renders wiki correctly" $ renderRoute (WikiR $ map Text.pack ["foo", "bar"]) @?= (map Text.pack ["wiki", "foo", "bar"], [])+        it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map Text.pack ["foo", "bar"], [(Text.pack "baz", Text.pack "bin")]))+            @?= (map Text.pack ["subsite", "foo", "bar"], [(Text.pack "baz", Text.pack "bin")])         it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c')-            @?= (map pack ["subparam", "6", "c"], [])+            @?= (map Text.pack ["subparam", "6", "c"], []) -    describe "thDispatch" $ do-        let disp m ps = dispatcher-                (Env-                    { envToMaster = id-                    , envMaster = MyApp-                    , envSub = MyApp-                    })-                (map pack ps, S8.pack m)-        it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR)-        it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)-        it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing :: Maybe (YRC.Route MyApp))-        it "routes to blog post" $ disp "GET" ["blog", "somepost"]-            @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost")-        it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]-            @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2")-        it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"]-            @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"])-        it "routes to subsite" $ disp "PUT" ["subsite", "baz"]-            @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], []))-        it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]-            @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')      describe "route parsing" $ do         it "subsites work" $ do-            parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?=-                Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")]))+            parseRoute ([Text.pack "subsite", Text.pack "foo"], [(Text.pack "bar", Text.pack "baz")]) @?=+                Just (SubsiteR $ MySubRoute ([Text.pack "foo"], [(Text.pack "bar", Text.pack "baz")]))      describe "routing table parsing" $ do         it "recognizes trailing backslashes as line continuation directives" $ do             let routes :: [ResourceTree String]-                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations")+                routes = $(parseRoutesFile "test/fixtures/routes_with_line_continuations.yesodroutes")             length routes @?= 3      describe "overlap checking" $ do@@ -316,9 +222,9 @@             findOverlapNames routes @?= []     describe "routeAttrs" $ do         it "works" $ do-            routeAttrs RootR @?= Set.fromList [pack "foo", pack "bar"]+            routeAttrs RootR @?= Set.fromList [Text.pack "foo", Text.pack "bar"]         it "hierarchy" $ do-            routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child")+            routeAttrs (ParentR (Text.pack "ignored") ChildR) @?= Set.singleton (Text.pack "child")     hierarchy     describe "parseRouteType" $ do         let success s t = it s $ parseTypeTree s @?= Just t@@ -335,17 +241,17 @@         success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")         success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" -getRootR :: Text-getRootR = pack "this is the root"+getRootR :: HandlerFor site Text+getRootR = pure $ Text.pack "this is the root" -getBlogPostR :: Text -> String-getBlogPostR t = "some blog post: " ++ unpack t+getBlogPostR :: Text -> HandlerFor site String+getBlogPostR t = pure $ "some blog post: " ++ Text.unpack t -postBlogPostR :: Text -> Text-postBlogPostR t = pack $ "POST some blog post: " ++ unpack t+postBlogPostR :: Text -> HandlerFor site Text+postBlogPostR t = pure $ Text.pack $ "POST some blog post: " ++ Text.unpack t -handleWikiR :: [Text] -> String-handleWikiR ts = "the wiki: " ++ show ts+handleWikiR :: [Text] -> HandlerFor site String+handleWikiR ts = pure $ "the wiki: " ++ show ts -getChildR :: Text -> Text-getChildR = id+getChildR :: Text -> HandlerFor site Text+getChildR = pure
test/YesodCoreTest.hs view
@@ -1,24 +1,53 @@-{-# LANGUAGE CPP                        #-}+{-# LANGUAGE CPP #-}+ module YesodCoreTest (specs) where  import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media+import YesodCoreTest.Meta import YesodCoreTest.Links import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings+import YesodCoreTest.SubSub+import YesodCoreTest.SplitSubsite.Runtime (splitSubsiteSpec)+import YesodCoreTest.ParameterizedSubData ()+import YesodCoreTest.ParamSubsite.Data ()+import YesodCoreTest.ParameterizedSubDispatch ()+import qualified YesodCoreTest.ParameterizedSubDispatchRuntime as ParameterizedSubDispatchRuntime+import qualified YesodCoreTest.ParamSubsite.InstanceRuntime as ParamSubsiteInstanceRuntime+import qualified YesodCoreTest.ParamSubsite.SplitRuntime as ParamSubsiteSplitRuntime+import qualified YesodCoreTest.ParamDefaultSplit.Runtime as ParamDefaultSplitRuntime+import qualified YesodCoreTest.ParamTopLevelRuntime as ParamTopLevelRuntime+import qualified YesodCoreTest.ParamFocusSplit.Runtime as ParamFocusSplit+import qualified YesodCoreTest.ParamNoExplicitArgs as ParamNoExplicitArgs+import qualified YesodCoreTest.ParamFallthroughRuntime as ParamFallthroughRuntime+import qualified YesodCoreTest.ParamNoFallthroughRuntime as ParamNoFallthroughRuntime+import qualified YesodCoreTest.ParamNestedNoFallthroughRuntime as ParamNestedNoFallthroughRuntime+import qualified YesodCoreTest.FallthroughMatrix.Runtime as FallthroughMatrixRuntime+import qualified YesodCoreTest.MultiPieceNestedRuntime as MultiPieceNestedRuntime+import qualified YesodCoreTest.ZeroPieceShadowRuntime as ZeroPieceShadowRuntime+import qualified YesodCoreTest.BangSeparatorRuntime as BangSeparatorRuntime+import qualified YesodCoreTest.SubsiteFallthrough.Runtime as SubsiteFallthrough+import qualified YesodCoreTest.SubsiteOptsFallthrough.Runtime as SubsiteOptsFallthrough import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache+import YesodCoreTest.ParameterizedSite+import YesodCoreTest.Breadcrumb import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect+import qualified YesodCoreTest.JsAttributes as JsAttributes import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json+import qualified YesodCoreTest.Content as Content+import qualified YesodCoreTest.NestedDispatch.Runtime as NestedDispatch+import qualified YesodCoreTest.FallthroughDispatch.Runtime as FallthroughDispatch  -- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450-#if !WINDOWS+#ifndef WINDOWS import qualified YesodCoreTest.RawResponse as RawResponse #endif @@ -40,15 +69,19 @@       mediaTest       linksTest       noOverloadedTest+      subSubTest+      splitSubsiteSpec       internalRequestTest       errorHandlingTest       cacheTest+      parameterizedSiteTest       WaiSubsite.specs       Redirect.specs+      JsAttributes.specs       JsLoader.specs       RequestBodySize.specs       Json.specs-#if !WINDOWS+#ifndef WINDOWS       RawResponse.specs #endif       Streaming.specs@@ -59,3 +92,26 @@       Ssl.sslOnlySpec       Ssl.sameSiteSpec       Csrf.csrfSpec+      breadcrumbTest+      metaTest+      Content.specs+      describe "NestedDispatch" $ do+          NestedDispatch.specs+      ParameterizedSubDispatchRuntime.specs+      ParamSubsiteInstanceRuntime.specs+      ParamSubsiteSplitRuntime.specs+      ParamDefaultSplitRuntime.specs+      ParamTopLevelRuntime.specs+      ParamFocusSplit.specs+      ParamNoExplicitArgs.specs+      ParamFallthroughRuntime.specs+      ParamNoFallthroughRuntime.specs+      ParamNestedNoFallthroughRuntime.specs+      FallthroughMatrixRuntime.specs+      MultiPieceNestedRuntime.specs+      ZeroPieceShadowRuntime.specs+      BangSeparatorRuntime.specs+      SubsiteFallthrough.specs+      SubsiteOptsFallthrough.specs+      describe "FallthroughDispatch" $ do+          FallthroughDispatch.spec
test/YesodCoreTest/Auth.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.Auth     ( specs     , Widget
+ test/YesodCoreTest/BangSeparatorRuntime.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | T2: a @!@-separated dynamic route (@\/!#Int@) is only ever exercised by the+-- render/parse specs (in the @test-routes@ suite's pure-routing @Hierarchy@+-- fixture). The @!@ flips /compile-time/ overlap checking only, so at runtime+-- @\/!#Int@ dispatches exactly like @\/#Int@. This pins that equivalence with a+-- real WAI round-trip.+module YesodCoreTest.BangSeparatorRuntime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertGet)++data BangApp = BangApp++mkYesod "BangApp" [parseRoutes|+/!#Int BackwardsR GET+/plain/#Int PlainR GET+|]++instance Yesod BangApp where+    messageLoggerSource = mempty++getBackwardsR :: Int -> HandlerFor BangApp Text+getBackwardsR i = pure (toPathPiece i <> ":backwards")++getPlainR :: Int -> HandlerFor BangApp Text+getPlainR i = pure (toPathPiece i <> ":plain")++req :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+req = assertGet BangApp++specs :: Spec+specs = describe "!-separator dynamic route dispatch (/!#Int)" $ do+    it "dispatches BackwardsR on a numeric piece, like a plain /#Int" $+        req 200 ["5"] (Just "5:backwards")+    it "still 404s a non-numeric piece (the # parser is unchanged by !)" $+        req 404 ["notanint"] Nothing+    it "dispatches the plain /#Int sibling for contrast" $+        req 200 ["plain", "7"] (Just "7:plain")
+ test/YesodCoreTest/Breadcrumb.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module YesodCoreTest.Breadcrumb+  ( breadcrumbTest,+  )+where++import Data.Text (Text)+import Network.Wai+import Network.Wai.Test+import Test.Hspec+import Yesod.Core++data A = A++mkYesod+  "A"+  [parseRoutes|+/    RootR GET+/loop LoopR GET+|]++instance Yesod A++instance YesodBreadcrumbs A where+  breadcrumb r = case r of+    RootR -> pure ("Root", Nothing)+    LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop++getRootR :: Handler Text+getRootR = fst <$> breadcrumbs++getLoopR :: Handler Text+getLoopR = fst <$> breadcrumbs++breadcrumbTest :: Spec+breadcrumbTest =+  describe "Test.Breadcrumb" $ do+    it "can fetch the root which contains breadcrumbs" $+      runner $ do+        res <- request defaultRequest+        assertStatus 200 res+    it "gets a 500 for a route with a looping breadcrumb" $+      runner $ do+        res <- request defaultRequest {pathInfo = ["loop"]}+        assertStatus 500 res++runner :: Session () -> IO ()+runner f = toWaiApp A >>= runSession f
test/YesodCoreTest/Cache.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.Cache     ( cacheTest     , Widget@@ -22,10 +25,8 @@ data C = C  newtype V1 = V1 Int-    deriving Typeable  newtype V2 = V2 Int-    deriving Typeable  mkYesod "C" [parseRoutes| /    RootR GET
test/YesodCoreTest/CleanPath.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.CleanPath     ( cleanPathTest     , Widget@@ -21,7 +25,6 @@ import qualified Data.Text.Encoding as TE import Control.Arrow ((***)) import Network.HTTP.Types (encodePath)-import Data.Monoid (mappend) import Data.Text.Encoding (encodeUtf8Builder)  data Subsite = Subsite@@ -64,7 +67,7 @@         corrected = filter (not . TS.null) s      joinPath Y ar pieces' qs' =-        encodeUtf8Builder ar `Data.Monoid.mappend` encodePath pieces qs+        encodeUtf8Builder ar `mappend` encodePath pieces qs       where         pieces = if null pieces' then [""] else pieces'         qs = map (TE.encodeUtf8 *** go) qs'
+ test/YesodCoreTest/Content.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module YesodCoreTest.Content (specs) where++import Test.Hspec++import Yesod.Core+import Yesod.Core.Types (TypedContent, typedContentToSnippet)+import Data.Text (Text, pack)+import Data.Text.Encoding (encodeUtf8)+import Data.ByteString (ByteString)++import qualified Data.Encoding as Enc+import qualified Data.Encoding.GB18030 as Enc+import qualified Data.Encoding.CP1251 as Enc+import qualified Data.Encoding.ShiftJIS as Enc+import qualified Data.Encoding.CP932 as Enc++fakeContent :: (String -> ByteString) -> String -> String -> TypedContent+fakeContent encode contentTypeString contentString =+  TypedContent+  (encode contentTypeString)+  (toContent $ encode contentString)++fakeUtf8Content :: String -> String -> TypedContent+fakeUtf8Content = fakeContent (encodeUtf8 . pack)++fakeGB18030Content :: String -> String -> TypedContent+fakeGB18030Content = fakeContent $ Enc.encodeStrictByteString Enc.GB18030++fakeCP1251Content :: String -> String -> TypedContent+fakeCP1251Content = fakeContent $ Enc.encodeStrictByteString Enc.CP1251++fakeShiftJISContent :: String -> String -> TypedContent+fakeShiftJISContent = fakeContent $ Enc.encodeStrictByteString Enc.ShiftJIS++fakeCP932Content :: String -> String -> TypedContent+fakeCP932Content = fakeContent $ Enc.encodeStrictByteString Enc.CP932++specs :: Spec+specs = describe "typedContentToSnippet" $ do+    it "does not serialize content that is apparently binary data" $ do+      let content = fakeUtf8Content "application/octet-stream" "fake"+      (typedContentToSnippet content 100) `shouldBe` Nothing++    it "serializes UTF-8 encoded JSON" $ do+      let content = fakeUtf8Content "application/json; charset=utf-8" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes text with no specified encoding" $ do+      let content = fakeUtf8Content "text/css" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "serializes RSS with no specified encoding" $ do+      let content = fakeUtf8Content "application/rss" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "serializes Atom feeds with no specified encoding" $ do+      let content = fakeUtf8Content "application/atom" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "truncates long snippets" $ do+      let content = fakeUtf8Content "application/json; charset=utf-8" "[1,2,3]"+      (typedContentToSnippet content 2) `shouldBe` (Just "[1...+ 5")++    it "serializes GB18030 text" $ do+      let content = fakeGB18030Content "application/json; charset=GB18030" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes CP1251 text" $ do+      let content = fakeCP1251Content "application/json; charset=windows-1251" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes ShiftJIS text" $ do+      let content = fakeShiftJISContent "application/json; charset=Shift_JIS" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes CP932 text" $ do+      let content = fakeCP932Content "application/json; charset=Windows-31J" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")
test/YesodCoreTest/Csrf.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}  module YesodCoreTest.Csrf (csrfSpec, Widget, resourcesApp) where @@ -10,7 +14,6 @@ import Web.Cookie import qualified Data.Map as Map import Data.ByteString.Lazy (fromStrict)-import Data.Monoid ((<>))  data App = App @@ -79,7 +82,7 @@          res <- request (defaultRequest { requestMethod = "POST", requestHeaders = [(defaultCsrfHeaderName, csrfValue <> "foo")] })         assertStatus 403 res-        +     it "403s write requests with the wrong CSRF param" $ runner $ do         getRes <- request defaultRequest         assertStatus 200 getRes
test/YesodCoreTest/ErrorHandling.hs view
@@ -1,26 +1,38 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.ErrorHandling     ( errorHandlingTest     , Widget     , resourcesApp     ) where++import  Data.Typeable(cast)+import qualified Control.Concurrent.Async as Async+import Control.Concurrent as Conc import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8-import Control.Exception (SomeException, try)+import Control.Exception (SomeException, try, AsyncException(..)) import Network.HTTP.Types (Status, mkStatus) import Data.ByteString.Builder (Builder, toLazyByteString)-import Data.Monoid (mconcat) import Data.Text (Text, pack) import Control.Monad (forM_)+import qualified Network.Wai.Handler.Warp as Warp+import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom import Control.Monad.Trans.State (StateT (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import qualified UnliftIO.Exception as E+import System.Timeout(timeout)  data App = App @@ -45,6 +57,10 @@ /auth-not-adequate AuthNotAdequateR GET /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET++/thread-killed ThreadKilledR GET+/connection-closed-by-peer ConnectionClosedPeerR GET+/sleep-sec SleepASecR GET |]  overrideStatus :: Status@@ -106,11 +122,28 @@ getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing  goodBuilderContent :: Builder-goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n"+goodBuilderContent = mconcat $ replicate 100 $ "This is a test\n"  getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent +-- this handler kills it's own thread+getThreadKilledR :: Handler Html+getThreadKilledR = do+  x <- liftIO Conc.myThreadId+  liftIO $ Async.withAsync (Conc.killThread x) Async.wait+  pure "unreachablle"+getSleepASecR :: Handler Html+getSleepASecR = do+  liftIO $ Conc.threadDelay 1000000+  pure "slept a second"++getConnectionClosedPeerR :: Handler Html+getConnectionClosedPeerR = do+  x <- liftIO Conc.myThreadId+  liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait+  pure "unreachablle"+ getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined@@ -154,6 +187,10 @@       it "accept CSS, permission denied -> 403" caseCssPermissionDenied       it "accept image, non-existent path -> 404" caseImageNotFound       it "accept video, bad method -> 405" caseVideoBadMethod+      it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows+      it "custom config rethrows an exception" caseCustomExceptionRethrows+      it "thread killed rethrow" caseThreadKilledRethrow+      it "can timeout a runner" canTimeoutARunner  runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f@@ -291,3 +328,50 @@                 ("accept", "video/webm") : requestHeaders defaultRequest             }     assertStatus 405 res++fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e+fromExceptionUnwrap se+  | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e+  | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e+  | otherwise = E.fromException se+++caseThreadKilledRethrow :: IO ()+caseThreadKilledRethrow =+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of+                                (Just ThreadKilled) -> True+                                _ -> False+  where+  testcode = runner $ do+                res <- request defaultRequest { pathInfo = ["thread-killed"] }+                assertStatus 500 res+                assertBodyContains "Internal Server Error" res++caseDefaultConnectionCloseRethrows :: IO ()+caseDefaultConnectionCloseRethrows =+  shouldThrow testcode $ \e -> case fromExceptionUnwrap e of+                                  Just Warp.ConnectionClosedByPeer -> True+                                  _ -> False++  where+  testcode = runner $ do+      _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] }+      pure ()++caseCustomExceptionRethrows :: IO ()+caseCustomExceptionRethrows =+  shouldThrow testcode $ \case Custom.MkMyException -> True+  where+    testcode = customAppRunner $ do+      _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] }+      pure ()+    customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f+++canTimeoutARunner :: IO ()+canTimeoutARunner = do+  res <- timeout 1000 $ runner $ do+    res <- request defaultRequest { pathInfo = ["sleep-sec"] }+    assertStatus 200 res -- if 500, it's catching the timeout exception+    pure () -- it should've timeout by now, either being 500 or Nothing+  res `shouldBe` Nothing -- make sure that pure statement didn't happen.
+ test/YesodCoreTest/ErrorHandling/CustomApp.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | a custom app that throws an exception+module YesodCoreTest.ErrorHandling.CustomApp+    (CustomApp(..)+    , MyException(..)++    -- * unused+    , Widget+    , resourcesCustomApp+    ) where++import Yesod.Core+import qualified UnliftIO.Exception as E++data CustomApp = CustomApp++mkYesod "CustomApp" [parseRoutes|+/throw-custom-exception CustomHomeR GET+|]++getCustomHomeR :: Handler Html+getCustomHomeR =+  E.throwIO MkMyException++data MyException = MkMyException+ deriving (Show, E.Exception)++instance Yesod CustomApp where+  -- something we couldn't do before, rethrow custom exceptions+  catchHandlerExceptions _ action handler =+    action `E.catch` \exception -> do+      case E.fromException exception of+        Just MkMyException -> E.throwIO MkMyException+        Nothing -> handler exception
test/YesodCoreTest/Exceptions.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.Exceptions     ( exceptionsTest     , Widget@@ -10,7 +14,7 @@ import Test.Hspec  import Yesod.Core-import Yesod.Core.Types (HandlerContents (HCError))+import Yesod.Core.Types (TypedContent, HandlerContents (HCError)) import Control.Exception (throwIO) import Network.Wai import Network.Wai.Test
+ test/YesodCoreTest/FallthroughDispatch/Resources.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Shared route table + foundation type for "YesodCoreTest.FallthroughDispatch.Runtime".+-- Two parents share the @\/foo@ prefix (@FirstFooR@\/@SecondFooR@), plus+-- @\/foo\/#Int@ and @\/foo\/#String@ parents — the deliberate overlap is why it+-- uses @parseRoutesNoCheck@ (the compile-time overlap check would otherwise+-- reject the shared prefix that the fallthrough behaviour exists to handle).+module YesodCoreTest.FallthroughDispatch.Resources where++import Yesod.Core+import Yesod.Routes.TH.Types++data App = App++fallthroughDispatchResources :: [ResourceTree String]+fallthroughDispatchResources = [parseRoutesNoCheck|++/foo   FirstFooR:+    /   FooIndexR+    /neat   FooNeatR++/foo   SecondFooR:+    /       NeverFiresR+    /other  OtherR++/foo/#Int  ParamFooR:+    /   FooWithIntR++/foo/#String TextFooR:+    /   FooWithTextR+|]
+ test/YesodCoreTest/FallthroughDispatch/Runtime.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | The single-module fallthrough contract demo for a top-level site, built+-- with @setNestedRouteFallthrough True@. Two same-prefix parents share @\/foo@:+-- @FirstFooR@ (with an index + @\/neat@) and @SecondFooR@ (@\/other@). With+-- fallthrough on, a request that misses inside @FirstFooR@ continues to the+-- sibling @SecondFooR@ instead of committing to @FirstFooR@'s 404 — the WAI+-- specs here pin exactly which parent serves each path. Route table in+-- ".FallthroughDispatch.Resources".+module YesodCoreTest.FallthroughDispatch.Runtime where++import YesodCoreTest.FallthroughDispatch.Resources+import YesodCoreTest.RuntimeHarness (assertGet)+import Yesod.Core+import Test.Hspec++mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "App" fallthroughDispatchResources++instance Yesod App++handleFooIndexR :: HandlerFor app String+handleFooIndexR = pure "FooIndexR"++handleOtherR :: HandlerFor app String+handleOtherR = pure "OtherR"++handleFooNeatR :: HandlerFor app String+handleFooNeatR = pure "FooNeatR"++handleNeverFiresR :: HandlerFor app String+handleNeverFiresR = pure "NeverFiresR"++handleFooWithIntR :: Int -> HandlerFor app String+handleFooWithIntR i = pure $ "FooWithIntR " <> show i++handleFooWithTextR :: String -> HandlerFor app String+handleFooWithTextR str = pure $ "FooWithTextR " <> str++spec :: Spec+spec = do+    describe "FirstFooR" $ do+        it "FooIndexR" $ do+            assertGet App 200 ["foo"] (Just "FooIndexR")++        it "FooNeatR" $ do+            assertGet App 200 ["foo", "neat"] (Just "FooNeatR")++    describe "SecondFooR" $ do+        -- This is a little unsatisfying. Ideally we could write a test+        -- that expresses that, uh, `renderRoute (SecondFooR NeverFiresR)`+        -- would always direct to a different route. Difficult to do+        -- though.+        it "NeverFiresR" $ do+            assertGet App 200 ["foo"] (Just "FooIndexR")++        it "OtherR" $ do+            assertGet App 200 ["foo", "other"] (Just "OtherR")++    describe "ParamFooR" $ do+        it "FooWithIntR" $ do+            assertGet App 200 ["foo", "3"] (Just "FooWithIntR 3")++    describe "TextFooR" $ do+        it "FooWithTextR" $ do+            assertGet App 200 ["foo", "asdf"] (Just "FooWithTextR asdf")
+ test/YesodCoreTest/FallthroughMatrix/FirstFoo.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | The split-out nested-dispatch instance for @FirstFooR@, generated with the+-- DEFAULT route options — i.e. @fallthrough = False@. The @FooIndexR@\/@FooNeatR@+-- handlers live ONLY here, so the top module ("YesodCoreTest.FallthroughMatrix.Runtime") can+-- compile only by delegating to the @YesodDispatchNested FirstFooR@ instance+-- generated by this splice (it cannot inline handlers it can't see).+--+-- This module's flag is @False@, but a nested instance must still report a+-- path miss as 'Nothing' rather than baking a 404 into its own terminal+-- fallback — the fallthrough decision belongs to whichever module delegates+-- to it. An instance that 404s on its own would silently defeat the top+-- module's @fallthrough = True@ intent.+module YesodCoreTest.FallthroughMatrix.FirstFoo where++import Yesod.Core+import YesodCoreTest.FallthroughMatrix.Resources++mkYesodOpts (setFocusOnNestedRoute "FirstFooR" defaultOpts) "FMApp" fmResources++getFooIndexR :: HandlerFor FMApp String+getFooIndexR = pure "FooIndexR"++getFooNeatR :: HandlerFor FMApp String+getFooNeatR = pure "FooNeatR"
+ test/YesodCoreTest/FallthroughMatrix/Resources.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Shared route table + site type for the cross-module fallthrough matrix.+--+-- Two parents share the @\/foo@ prefix: @FirstFooR@ (whose nested instance is+-- generated in a /separate/ module, "YesodCoreTest.FallthroughMatrix.FirstFoo",+-- with the default @fallthrough = False@) and @SecondFooR@ (inlined in the+-- top module "YesodCoreTest.FallthroughMatrix.Runtime", which sets+-- @fallthrough = True@). The flag mismatch across the module split is the whole+-- point: it lets us pin who owns the terminal 404 on @\/foo\/other@.+--+-- @FirstFooR@ owns @\/foo\/neat@ as @GET@-only; @SecondFooR@ owns the same+-- @\/foo\/neat@ path as @POST@-only. This shared @neat@ leaf is what pins the+-- wrong-method contract under fallthrough: a @POST \/foo\/neat@ matches+-- @FirstFooR@'s @GET@ leaf /by path/ and so must commit to 405 — fallthrough is+-- only triggered by a path miss ('Nothing'), and a matched-path/wrong-method+-- leaf returns @Just \<405\>@, never 'Nothing'. If it instead fell through to+-- @SecondFooR@'s @POST@ leaf it would 200, which would be a contract change.+module YesodCoreTest.FallthroughMatrix.Resources where++import Yesod.Core+import Yesod.Routes.TH.Types++data FMApp = FMApp++fmResources :: [ResourceTree String]+fmResources = [parseRoutesNoCheck|+/foo   FirstFooR:+    /      FooIndexR  GET+    /neat  FooNeatR   GET++/foo   SecondFooR:+    /       NeverFiresR  GET+    /other  OtherR       GET+    /neat   NeatPostR    POST+|]
+ test/YesodCoreTest/FallthroughMatrix/Runtime.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Cross-module fallthrough flag mismatch: the delegating module and the+-- split-out nested instance are compiled with opposite fallthrough flags.+--+-- This top module sets @fallthrough = True@ and delegates @FirstFooR@ to the+-- nested instance generated (with the default @fallthrough = False@) in+-- "YesodCoreTest.FallthroughMatrix.FirstFoo". @SecondFooR@ is inlined here.+--+-- The single-module analogue "YesodCoreTest.ParamFallthroughRuntime" proves+-- that with fallthrough enabled, @\/foo\/other@ falls through @FirstFooR@ (which+-- has no @other@ child) to @SecondFooR@ → @OtherR@ (200). This module is the+-- same shape but with @FirstFooR@'s instance split into a module compiled with+-- the opposite flag — the configuration that only works because a nested+-- instance reports a path miss as 'Nothing' instead of baking in its own 404,+-- leaving the fallthrough decision to the module that delegates to it.+module YesodCoreTest.FallthroughMatrix.Runtime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.FallthroughMatrix.Resources+import YesodCoreTest.FallthroughMatrix.FirstFoo (FirstFooR(..))+import YesodCoreTest.RuntimeHarness (assertGet, assertRequestFor)++mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "FMApp" fmResources++instance Yesod FMApp where+    messageLoggerSource = mempty++getNeverFiresR :: HandlerFor FMApp String+getNeverFiresR = pure "NeverFiresR"++getOtherR :: HandlerFor FMApp String+getOtherR = pure "OtherR"++postNeatPostR :: HandlerFor FMApp String+postNeatPostR = pure "NeatPostR"++testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+testRequestIO = assertGet FMApp++specs :: Spec+specs = describe "cross-module fallthrough flag mismatch (top True, split child False)" $ do+    it "matches the split child's index (FooIndexR at /foo)" $+        testRequestIO 200 ["foo"] (Just "FooIndexR")+    it "matches a child of the split parent (FooNeatR at /foo/neat)" $+        testRequestIO 200 ["foo", "neat"] (Just "FooNeatR")+    it "falls through the split parent to the inline sibling (OtherR at /foo/other)" $+        -- The headline case. The top module wants fallthrough; FirstFooR has+        -- no "other" child, so dispatch falls through to SecondFooR's OtherR+        -- (200). If FirstFooR's split instance (compiled with flag False)+        -- instead baked a 404 into its own terminal fallback, it would defeat+        -- the parent's fallthrough.+        testRequestIO 200 ["foo", "other"] (Just "OtherR")++    -- Terminal semantics of fallthrough. Fallthrough is triggered+    -- ONLY by a path-level miss (a 'Nothing' from the matched parent): a+    -- matched leaf — even one rejecting the method — returns @Just <405>@, so+    -- dispatch commits to that leaf and never falls through to a same-prefix+    -- sibling. These rows pin both halves of that contract.+    describe "wrong method on a matched leaf commits (does not fall through)" $ do+        it "POST /foo/neat commits to 405 at FirstFooR's GET leaf" $+            -- FirstFooR owns /foo/neat as GET-only and SecondFooR owns the same+            -- /foo/neat path as POST-only. A POST matches FirstFooR's leaf by+            -- PATH, so the split (fallthrough=False) FirstFooR instance returns+            -- Just <405> — it does NOT return Nothing — and the host's+            -- fallthrough arm therefore commits to 405 rather than falling+            -- through to SecondFooR's POST leaf (which would be 200). If this+            -- ever flips to 200, fallthrough has started swallowing a matched+            -- leaf's method rejection, which is a contract change.+            assertRequestFor FMApp "POST" 405 ["foo", "neat"] Nothing+        it "GET /foo/neat still serves FirstFooR's GET leaf (200)" $+            -- The mirror of the above: the same shared path under the right+            -- method resolves to the first matching leaf, never SecondFooR.+            testRequestIO 200 ["foo", "neat"] (Just "FooNeatR")++    describe "total miss under fallthrough lands on the terminal 404" $ do+        it "GET /foo/zzz exhausts both same-prefix parents -> 404" $+            -- /foo/zzz matches the /foo prefix of both FirstFooR and SecondFooR+            -- but no leaf of either. Each parent reports a path miss ('Nothing'),+            -- so dispatch falls through every sibling and lands on the terminal+            -- 404 clause ("except in the final case" from the flag's haddock).+            testRequestIO 404 ["foo", "zzz"] Nothing+        it "GET /zzz matches no parent prefix at all -> 404" $+            -- A top-level total miss: no parent's prefix matches, so the only+            -- clause that fires is the terminal 404.+            testRequestIO 404 ["zzz"] Nothing
test/YesodCoreTest/Header.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes,-  TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}  module YesodCoreTest.Header   ( headerTest
test/YesodCoreTest/InternalRequest.hs view
@@ -1,20 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}+ module YesodCoreTest.InternalRequest (internalRequestTest) where  import Data.List (nub) import Network.Wai as W import Yesod.Core.Internal (randomString, parseWaiRequest) import Test.Hspec-import Data.Monoid (mempty) import Data.Map (singleton) import Yesod.Core import Data.Word (Word64) import System.IO.Unsafe (unsafePerformIO) import Control.Monad (replicateM)-import System.Random+import System.Random (randomIO)  gen :: IO Int-gen = getStdRandom next+gen = randomIO  randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do@@ -57,7 +57,7 @@  noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where-  r = parseWaiRequest' defaultRequest Data.Monoid.mempty False 1000+  r = parseWaiRequest' defaultRequest mempty False 1000  ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where
+ test/YesodCoreTest/JsAttributes.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.JsAttributes+    ( specs+      -- To avoid unused warning+    , Widget+    , resourcesApp+    ) where++import Test.Hspec++import Yesod.Core+import Network.Wai.Test++data App = App+mkYesod "App" [parseRoutes|+/ HeadR GET+|]+instance Yesod App where+    jsAttributes _ = [("attr0", "a")]++getHeadR :: Handler Html+getHeadR = defaultLayout $ do+    addScriptRemote "load.js"+    toWidget [julius|/*body*/|]+    toWidgetHead [julius|/*head*/|]++specs :: Spec+specs = describe "Test.JsAttributes" $ do+    it "script in body gets attributes" $ runner App $ do+      res <- request defaultRequest+      assertBody "<!DOCTYPE html>\n<html><head><title></title><script>/*head*/</script></head><body><script src=\"load.js\"></script><script attr0=\"a\">/*body*/</script></body></html>" res++runner :: YesodDispatch master => master -> Session () -> IO ()+runner app f = toWaiApp app >>= runSession f
test/YesodCoreTest/JsLoader.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.JsLoader     ( specs     , Widget
test/YesodCoreTest/JsLoaderSites/Bottom.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.JsLoaderSites.Bottom     ( B(..)     , Widget
test/YesodCoreTest/Json.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.Json     ( specs     , Widget
test/YesodCoreTest/Links.hs view
@@ -1,6 +1,11 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.Links     ( linksTest     , Widget
test/YesodCoreTest/LiteApp.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module YesodCoreTest.LiteApp (specs) where  import Yesod.Core
test/YesodCoreTest/Media.hs view
@@ -1,7 +1,12 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module YesodCoreTest.Media (mediaTest, Widget) where  import Test.Hspec
test/YesodCoreTest/MediaData.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.MediaData where  import Yesod.Core
+ test/YesodCoreTest/Meta.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module YesodCoreTest.Meta+    ( metaTest+    ) where++import Test.Hspec++import Yesod.Core+import Network.Wai+import Network.Wai.Test++data App = App++mkYesod "App" [parseRoutes|+/title TitleR GET+/desc  DescriptionR GET+|]++instance Yesod App where++getTitleR :: Handler Html+getTitleR = defaultLayout $ do+    setTitle "First title"+    setTitle "Second title"++getDescriptionR :: Handler Html+getDescriptionR = defaultLayout $ do+    setDescriptionIdemp "First description"+    setDescriptionIdemp "Second description"++metaTest :: Spec+metaTest = describe "Setting page metadata" $ do+    describe "Yesod.Core.Widget.setTitle" $ do+        it "is idempotent" $ runner $ do+            res <- request defaultRequest+                        { pathInfo = ["title"]+                        }+            assertBody "<!DOCTYPE html>\n<html><head><title>Second title</title></head><body></body></html>" res+    describe "Yesod.Core.Widget.setDescriptionIdemp" $ do+        it "is idempotent" $ runner $ do+            res <- request defaultRequest+                        { pathInfo = ["desc"]+                        }+            assertBody "<!DOCTYPE html>\n<html><head><title></title><meta name=\"description\" content=\"Second description\"></head><body></body></html>" res++runner :: Session () -> IO ()+runner f = toWaiAppPlain App >>= runSession f
+ test/YesodCoreTest/MultiPieceNestedRuntime.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | T3: a nested 'ResourceParent' whose OWN path pieces number more than one+-- and include a dynamic capture (@\/shop\/#Int\/admin@). Most nested-route tests+-- use single-piece parents; this stresses the multi-piece machinery —+-- 'handlePiecesNames' binding several pieces, 'mkPathPat' threading them, and+-- the @parentArgsExp@ tuple build that forwards the captured @#Int@ down to the+-- delegated child dispatch — and asserts both the round-trip and the misses.+module YesodCoreTest.MultiPieceNestedRuntime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertGet)++data MPApp = MPApp++mkYesod "MPApp" [parseRoutes|+/shop/#Int/admin ShopAdminR:+    /            ShopAdminIndexR  GET+    /users/#Text UserR            GET+|]++instance Yesod MPApp where+    messageLoggerSource = mempty++getShopAdminIndexR :: Int -> HandlerFor MPApp String+getShopAdminIndexR shopId = pure ("admin:" <> show shopId)++getUserR :: Int -> Text -> HandlerFor MPApp String+getUserR shopId name = pure ("user:" <> show shopId <> ":" <> show name)++testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+testRequestIO = assertGet MPApp++specs :: Spec+specs = describe "multi-piece nested parent (/shop/#Int/admin)" $ do+    it "dispatches the parent index, forwarding the captured #Int" $+        testRequestIO 200 ["shop", "5", "admin"] (Just "admin:5")+    it "dispatches a child, forwarding both the parent #Int and child #Text" $+        testRequestIO 200 ["shop", "5", "admin", "users", "bob"] (Just "user:5:\"bob\"")+    it "404s on an unknown suffix under the multi-piece parent" $+        testRequestIO 404 ["shop", "5", "admin", "nope"] Nothing+    it "404s when the parent's dynamic piece is malformed (#Int given a non-integer)" $+        testRequestIO 404 ["shop", "notanint", "admin"] Nothing
+ test/YesodCoreTest/NestedDispatch/InnerR.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Bug-2 regression fixture: @InnerR@ is split out into its own focused+-- module (so a @RouteAttrsNested InnerR@ instance is in scope), while its+-- parent @OuterR@ is /not/ split — the main @App@ module inlines @OuterR@.+--+-- When the full @RouteAttrs App@ instance descends through the inlined+-- @OuterR@ and reaches the delegated @InnerR@, the generated @routeAttrs@+-- clause must apply the accumulated ancestor pattern (@front@), producing+-- @routeAttrs (OuterR (InnerR _ x)) = routeAttrsNested x@. Dropping @front@+-- (the bug) would emit @routeAttrs (InnerR x) = …@, which fails to compile+-- because @Route App@ has no top-level @InnerR@ constructor.+module YesodCoreTest.NestedDispatch.InnerR where++import Data.Text (Text)+import YesodCoreTest.NestedDispatch.Resources+import Yesod.Core++mkYesodOpts (setFocusOnNestedRoute "InnerR" defaultOpts) "App" nestedDispatchResources++getInnerIndexR :: HandlerFor App Text+getInnerIndexR = pure "getInnerIndexR"
+ test/YesodCoreTest/NestedDispatch/NestR.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Split-out @NestR@ fragment of the "YesodCoreTest.NestedDispatch.Runtime" demo. The+-- @setFocusOnNestedRoute "NestR"@ splice generates the @NestR@ datatype and its+-- @YesodDispatchNested@ instance here; the @App@ module delegates to it. The+-- single @NestIndexR@ leaf handles both GET and POST, covering a zero-piece+-- nested index reached through delegation.+module YesodCoreTest.NestedDispatch.NestR where++import Yesod.Core+import Data.Text (Text)+import YesodCoreTest.NestedDispatch.Resources++mkYesodOpts (setFocusOnNestedRoute "NestR" defaultOpts) "App" nestedDispatchResources++getNestIndexR :: HandlerFor App Text+getNestIndexR = pure "getNestIndexR"++postNestIndexR :: HandlerFor App String+postNestIndexR = pure "hello"
+ test/YesodCoreTest/NestedDispatch/Parent0R.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+++-- | Split-out @Parent0R@ fragment of the "YesodCoreTest.NestedDispatch.Runtime" demo.+-- Besides delegation, this module pins two non-obvious cases: a multipiece+-- (@*Texts@) leaf under a split-out parent (see 'getFilesR' below), and a+-- /grandchild/ parent @Child0R@ nested two levels deep. This focused splice+-- generates both @Parent0R@ and its grandchild @Child0R@ datatype\/instance;+-- the grandchild's leaf /handlers/ live in+-- "YesodCoreTest.NestedDispatch.Parent0R.Child0R".+module YesodCoreTest.NestedDispatch.Parent0R where++import Data.Text (Text)+import qualified Data.Text as Text+import Yesod.Core.Handler+import YesodCoreTest.NestedDispatch.Resources+import Yesod.Core+import YesodCoreTest.NestedDispatch.Parent0R.Child0R++mkYesodOpts (setFocusOnNestedRoute "Parent0R" defaultOpts) "App" nestedDispatchResources++getParent0IndexR :: Int -> HandlerFor App Text+getParent0IndexR = pure . Text.pack . show++-- | A multi-piece (@*Texts@) leaf nested under a split-out parent. This is the+-- regression fixture for the nested-dispatch generator dropping the trailing+-- multipiece (it hardcoded 'EndExact' and built the constructor one arg short),+-- which fails to compile this focused dispatch unless the multi is bound,+-- appended to the route constructor, and forwarded to the handler.+getFilesR :: Int -> [Text] -> HandlerFor App Text+getFilesR i ts = return (Text.pack (show i) <> ":" <> Text.pack (show ts))
+ test/YesodCoreTest/NestedDispatch/Parent0R/Child0R.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Leaf handlers for the grandchild parent @Child0R@ of the+-- "YesodCoreTest.NestedDispatch.Runtime" demo. Non-obvious: this module defines /only/+-- the handlers — the @Child0R@ datatype and its dispatch instance are emitted+-- by the focused @Parent0R@ splice (one level up), since focusing on a parent+-- also generates its descendants' nested instances.+module YesodCoreTest.NestedDispatch.Parent0R.Child0R where++import Data.Text (Text)+import qualified Data.Text as Text+import Yesod.Core.Handler+import YesodCoreTest.NestedDispatch.Resources+import Yesod.Core++postParentChildIndexR :: Int -> Text -> HandlerFor App Text+postParentChildIndexR i t = pure $ Text.pack $ show (i, t)++getParentChildIndexR :: Int -> Text -> HandlerFor App Text+getParentChildIndexR = postParentChildIndexR++postParentChildR :: Int -> Text -> String -> HandlerFor App Text+postParentChildR i t c = pure $ Text.pack $ show (i, t, c)++getParentChildR :: Int -> Text -> String -> HandlerFor App Text+getParentChildR = postParentChildR
+ test/YesodCoreTest/NestedDispatch/ParentR.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Split-out @ParentR@ fragment of the "YesodCoreTest.NestedDispatch.Runtime" demo.+-- The @setFocusOnNestedRoute "ParentR"@ splice emits the @ParentR@ datatype and+-- its @YesodDispatchNested@ instance here, alongside the child handlers; the+-- main @App@ module reaches these only by delegation. Exercises a dynamic+-- parent piece (@\/parent\/#Int@) feeding its captured arg to the children.+module YesodCoreTest.NestedDispatch.ParentR where++import Data.Text (Text)+import qualified Data.Text as Text+import Yesod.Core.Handler+import YesodCoreTest.NestedDispatch.Resources+import Yesod.Core++mkYesodOpts (setFocusOnNestedRoute "ParentR" defaultOpts) "App" nestedDispatchResources++handleChild1R :: Int -> Text -> HandlerFor App  Text+handleChild1R i t = return (Text.pack (show i) <> t)++getChild2R :: Int -> Int -> HandlerFor App Text+getChild2R i0 i1 = return ("GET" <> Text.pack (show (i0, i1)))++postChild2R :: Int -> Int -> HandlerFor App Text+postChild2R i0 i1 = return ("POST" <> Text.pack (show (i0, i1)))
+ test/YesodCoreTest/NestedDispatch/Resources.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Shared route table + foundation type for the "YesodCoreTest.NestedDispatch.Runtime"+-- demo and its split-out parent modules. Lives in its own module so every+-- @setFocusOnNestedRoute@ splice (NestR, ParentR, Parent0R, ...) can refer to+-- the same @nestedDispatchResources@ tree without tripping the TH stage+-- restriction. The tree deliberately mixes flat routes, single- and+-- multi-piece dynamic parents, a multipiece (@*Texts@) leaf, and same-prefix+-- siblings to exercise the breadth of the nested-dispatch generator.+module YesodCoreTest.NestedDispatch.Resources where++import Yesod.Core+import Yesod.Routes.TH.Types++data App = App++nestedDispatchResources :: [ResourceTree String]+nestedDispatchResources = [parseRoutes|+/     HomeR GET !home+/json JsonR GET++/redirectparent RedirectParentR GET+/redirecttext   RedirectTextR   GET+/redirectstring RedirectStringR GET+/redirectparams RedirectParamsR GET+/nest NestR:+    / NestIndexR GET POST++/parent/#Int ParentR:+    /#Text/child1 Child1R !child+    /#Int/child2 Child2R !child GET POST++/parent0/#Int Parent0R:+    / Parent0IndexR GET++    /files/*Texts FilesR GET++    /child0/#Text Child0R:+        / ParentChildIndexR GET POST+        /#String ParentChildR GET POST++/nest OtherNestR:+    /foo NestFooR GET++/outer OuterR:+    /inner InnerR:+        / InnerIndexR GET !innerleaf++/blah BlahR:+    /   BlahIndexR GET++/robots.txt RobotsR:+    /   RobotsIndexR+|]
+ test/YesodCoreTest/NestedDispatch/Runtime.hs view
@@ -0,0 +1,599 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- | The headline nested-route-dispatch demo. @mkYesod "App"@ here generates a+-- @YesodDispatch App@ whose flat dispatch /delegates/ to a per-parent+-- @YesodDispatchNested@ instance for every @ResourceParent@ in the tree (NestR,+-- ParentR, Parent0R, OuterR, ...). Each such instance is generated in-splice by+-- this module, /unless/ a sibling module already provides it: NestR\/ParentR\/+-- Parent0R\/Child0R are split out (each via @setFocusOnNestedRoute@) so their+-- handlers and instances live elsewhere and are only reached through delegation.+-- The .Resources module holds the shared route table; the WAI specs here drive+-- real requests through the delegated dispatch.+module YesodCoreTest.NestedDispatch.Runtime+    ( specs+    , Widget+    , resourcesApp+    ) where++import Yesod.Core+import Yesod.Core.Class.Dispatch.ToParentRoute (toParentRoute)+import Test.Hspec+import Network.Wai+import Network.Wai.Test+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Maybe (fromJust)+import Data.Proxy (Proxy (..))+import Data.Monoid (Endo (..))+import qualified Control.Monad.Trans.Writer    as Writer+import qualified Data.Set as Set+import YesodCoreTest.NestedDispatch.Resources+import YesodCoreTest.NestedDispatch.NestR (NestR(..))+import YesodCoreTest.NestedDispatch.InnerR (InnerR(..))+import YesodCoreTest.NestedDispatch.ParentR (ParentR(..))+import YesodCoreTest.NestedDispatch.Parent0R (Parent0R(..), Child0R(..))+import YesodCoreTest.NestedDispatch.Parent0R.Child0R+import YesodCoreTest.RuntimeHarness (assertRequestRaw)+import qualified Network.HTTP.Types as H++mkYesod "App" nestedDispatchResources++getBlahIndexR :: HandlerFor App Text+getBlahIndexR = pure "getBlahIndexR"++instance Yesod App where+    messageLoggerSource = mempty++specialHtml :: IsString a => a+specialHtml = "text/html; charset=special"++tshow :: Show a => a -> Text+tshow = Text.pack . show++handleRobotsIndexR :: HandlerFor site Text+handleRobotsIndexR = pure "robots.txt"++getHomeR :: Handler TypedContent+getHomeR = selectRep $ do+    rep typeHtml "HTML"+    rep specialHtml "HTMLSPECIAL"+    rep typeXml "XML"+    rep typeJson "JSON"++getNestFooR :: Handler ()+getNestFooR = pure ()++-- | Redirects through the 'RedirectUrl' instance for 'WithParentArgs', which+-- routes via @toTextUrl (toParentRoute args url)@. Pins that the Location+-- header for a nested fragment is rendered identically to the full route.+getRedirectParentR :: Handler ()+getRedirectParentR = redirect (WithParentArgs (1 :: Int) (Child1R "hello"))++-- | Exercises @RedirectUrl master Text@.+getRedirectTextR :: Handler ()+getRedirectTextR = redirect ("/some/where" :: Text)++-- | Exercises @RedirectUrl master String@.+getRedirectStringR :: Handler ()+getRedirectStringR = redirect ("/some/string" :: String)++-- | Exercises @RedirectUrl master (Route master, [(Text, Text)])@.+getRedirectParamsR :: Handler ()+getRedirectParamsR = redirect (JsonR, [("q", "1")] :: [(Text, Text)])++rep :: Monad m => ContentType -> Text -> Writer.Writer (Data.Monoid.Endo [ProvidedRep m]) ()+rep ct t = provideRepType ct $ return (t :: Text)++getJsonR :: Handler TypedContent+getJsonR = selectRep $ do+  rep typeHtml "HTML"+  provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]++testRequest :: Int -- ^ http status code+            -> Request+            -> ByteString -- ^ expected body+            -> Spec+testRequest status req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do+    testRequestIO status req (Just expected)++testRequestIO :: HasCallStack => Int -- ^ http status code+            -> Request+            -> Maybe ByteString -- ^ expected body+            -> IO ()+testRequestIO status req mexpected =+    assertRequestRaw (toWaiApp App) req status mexpected++test :: String -- ^ accept header+     -> ByteString -- ^ expected body+     -> Spec+test accept expected =+    testRequest 200 (acceptRequest accept) expected++acceptRequest :: String -> Request+acceptRequest accept = defaultRequest+            { requestHeaders = [("Accept", S8.pack accept)]+            }++-- | Build a WAI app rooted at a nested route fragment (via the public+-- 'toWaiAppPlainNested' entry point), issue one GET at @path@, and return the+-- status code.+nestedStatusFor+    :: (ParentSite route ~ App, YesodDispatchNested route, ToParentRoute route)+    => Proxy route -> ParentArgs route -> [Text] -> IO Int+nestedStatusFor proxy parentArgs path = do+    app <- toWaiAppPlainNested proxy parentArgs App+    sres <- flip runSession app $ request defaultRequest { pathInfo = path }+    pure $ H.statusCode (simpleStatus sres)+++specs :: Spec+specs = do+    describe "Dispatch" $ do+        describe "properly does nested dispatch" $ do+            describe "NestR" $ do+                it "GET" $ do+                    testRequestIO+                        200+                        defaultRequest+                            { pathInfo = ["nest"]+                            , requestMethod = "GET"+                            }+                        (Just "getNestIndexR")+                it "POST" $ do+                    testRequestIO+                        200+                        defaultRequest+                            { pathInfo = ["nest"]+                            , requestMethod = "POST"+                            }+                        (Just "hello")+                it "invalid route" $ do+                    testRequestIO+                        404+                        defaultRequest+                            { pathInfo = ["nest", "oops"]+                            , requestMethod = "GET"+                            }+                        Nothing+                it "invalid method" $ do+                    testRequestIO+                        405+                        defaultRequest+                            { pathInfo = ["nest"]+                            , requestMethod = "PUT"+                            }+                        Nothing++            describe "ParentR" $ do+                describe "Child1R" $ do+                    it "works" $ do+                        testRequestIO+                            200+                            defaultRequest+                                { pathInfo =+                                    ["parent", tshow @Int 1, "hello", "child1"]+                                }+                            (Just "1hello")++                describe "Child2R" $ do+                    it "GET" $ do+                        testRequestIO+                            200+                            defaultRequest+                                { pathInfo =+                                    ["parent", tshow @Int 1, tshow @Int 3, "child2"]+                                , requestMethod = "GET"+                                }+                            (Just "GET(1,3)")+                    it "POST" $ do+                        testRequestIO+                            200+                            defaultRequest+                                { pathInfo =+                                    ["parent", tshow @Int 1, tshow @Int 3, "child2"]+                                , requestMethod = "POST"+                                }+                            (Just "POST(1,3)")+                    it "PUT" $ do+                        testRequestIO+                            405+                            defaultRequest+                                { pathInfo =+                                    ["parent", tshow @Int 1, tshow @Int 3, "child2"]+                                , requestMethod = "PUT"+                                }+                            Nothing++            describe "Parent0R" $ do+                describe "FilesR (multi-piece *Texts leaf under a split parent)" $ do+                    it "dispatches a non-empty tail, forwarding parent #Int and the multipiece" $ do+                        testRequestIO+                            200+                            defaultRequest+                                { pathInfo = ["parent0", tshow @Int 7, "files", "a", "b"]+                                , requestMethod = "GET"+                                }+                            (Just "7:[\"a\",\"b\"]")+                    it "dispatches an empty tail as the empty multipiece" $ do+                        testRequestIO+                            200+                            defaultRequest+                                { pathInfo = ["parent0", tshow @Int 7, "files"]+                                , requestMethod = "GET"+                                }+                            (Just "7:[]")+                    it "405s on a non-GET method" $ do+                        testRequestIO+                            405+                            defaultRequest+                                { pathInfo = ["parent0", tshow @Int 7, "files", "a", "b"]+                                , requestMethod = "POST"+                                }+                            Nothing++                describe "Parent0IndexR" $ do+                    it "GET works" $ do+                        testRequestIO+                            200+                            defaultRequest+                                { pathInfo =+                                    ["parent0", tshow @Int 1]+                                , requestMethod = "GET"+                                }+                            (Just "1")+                    it "POST errors" $ do+                        testRequestIO+                            405+                            defaultRequest+                                { pathInfo =+                                    ["parent0", tshow @Int 1]+                                , requestMethod = "POST"+                                }+                            Nothing++                describe "Child0R" $ do+                    describe "ParentChildIndexR" $ do+                        it "GET works" $ do+                            testRequestIO+                                200+                                defaultRequest+                                    { pathInfo =+                                        ["parent0", tshow @Int 1, "child0", "asdf"]+                                    , requestMethod = "GET"+                                    }+                                (Just "(1,\"asdf\")")+                        it "POST works" $ do+                            testRequestIO+                                200+                                defaultRequest+                                    { pathInfo =+                                        ["parent0", tshow @Int 2, "child0", "asdf"]+                                    , requestMethod = "POST"+                                    }+                                (Just "(2,\"asdf\")")+                        it "PUT errors" $ do+                            testRequestIO+                                405+                                defaultRequest+                                    { pathInfo =+                                        ["parent0", tshow @Int 2, "child0", "asdf"]+                                    , requestMethod = "PUT"+                                    }+                                Nothing++                    describe "ParentChildR" $ do+                        it "GET works" $ do+                            testRequestIO+                                200+                                defaultRequest+                                    { pathInfo =+                                        ["parent0", tshow @Int 1, "child0", "asdf", "foobar"]+                                    , requestMethod = "GET"+                                    }+                                (Just "(1,\"asdf\",\"foobar\")")+                        it "POST works" $ do+                            testRequestIO+                                200+                                defaultRequest+                                    { pathInfo =+                                        ["parent0", tshow @Int 1, "child0", "asdf", "foobar"]+                                    , requestMethod = "POST"+                                    }+                                (Just "(1,\"asdf\",\"foobar\")")+                        it "PUT fails" $ do+                            testRequestIO+                                405+                                defaultRequest+                                    { pathInfo =+                                        ["parent0", tshow @Int 1, "child0", "asdf", "foobar"]+                                    , requestMethod = "PUT"+                                    }+                                Nothing++    describe "trailing-slash redirect (cleanPath) for a nested route" $ do+        it "301s a trailing slash on a GET to a split nested route" $ do+            testRequestIO+                301+                defaultRequest+                    { pathInfo = ["parent", tshow @Int 1, tshow @Int 3, "child2", ""]+                    , requestMethod = "GET"+                    }+                Nothing++    describe "nested-dispatch entry points (miss / deep 404)" $ do+        -- These exercise toWaiAppPlainNested/toWaiAppYreNested directly, not just+        -- the happy path. In particular they cover the `Nothing -> notFound`+        -- branch in toWaiAppYreNested (a fragment instance returning Nothing on a+        -- non-match) and confirm a `drop parentDepth` against a too-short pathInfo+        -- yields a clean 404 rather than a mis-dispatch.+        describe "rooted at NestR (no dynamic prefix, depth 1)" $ do+            it "dispatches the matching index path" $+                nestedStatusFor (Proxy :: Proxy NestR) () ["nest"]+                    `shouldReturn` 200+            it "404s a non-matching tail through the Nothing -> notFound branch" $+                nestedStatusFor (Proxy :: Proxy NestR) () ["nest", "oops"]+                    `shouldReturn` 404++        describe "rooted at a deep dynamic parent (ParentR/#Int, depth 2)" $ do+            it "dispatches a full matching path" $+                nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int)+                    ["parent", "1", "hello", "child1"]+                    `shouldReturn` 200+            it "cleanly 404s a pathInfo shorter than the parent depth" $+                nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int) ["parent"]+                    `shouldReturn` 404+            it "cleanly 404s an empty pathInfo" $+                nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int) []+                    `shouldReturn` 404+            it "404s a non-matching deep tail" $+                nestedStatusFor (Proxy :: Proxy ParentR) (1 :: Int)+                    ["parent", "1", "nope"]+                    `shouldReturn` 404++    describe "UrlToDispatch NestIndexR" $ do+        it "works" $ do+            yre <- mkYesodRunnerEnv App+            let app = urlToDispatch NestIndexR yre+                req = defaultRequest+                    { pathInfo = ["nest"]+                    , requestMethod = "GET"+                    }+            sres <- flip runSession app $ do+                request req+            H.statusCode (simpleStatus sres) `shouldBe` 200+            simpleBody sres `shouldBe` "getNestIndexR"++    describe "UrlToDispatch (WithParentArgs route)" $ do+        -- Exercises the only UrlToDispatch instance with real args-threading+        -- logic (Yesod.Core.Class.Dispatch): a fragment plus its dynamic parent+        -- args is turned into a WAI app that dispatches into the right handler.+        it "dispatches a dynamic-parent fragment to the right handler (200)" $ do+            yre <- mkYesodRunnerEnv App+            let app =+                    urlToDispatch+                        (WithParentArgs (1 :: Int) (Child1R "hello"))+                        yre+                req = defaultRequest+                    { pathInfo = ["parent", "1", "hello", "child1"]+                    , requestMethod = "GET"+                    }+            sres <- flip runSession app $ request req+            H.statusCode (simpleStatus sres) `shouldBe` 200+            simpleBody sres `shouldBe` "1hello"+        it "404s a path whose parent arg disagrees with the request path" $ do+            -- The fragment app is rooted at parent arg 1, but it still parses the+            -- path off the request; a path that doesn't match the fragment 404s.+            yre <- mkYesodRunnerEnv App+            let app =+                    urlToDispatch+                        (WithParentArgs (1 :: Int) (Child1R "hello"))+                        yre+                req = defaultRequest+                    { pathInfo = ["parent", "1", "hello", "nope"]+                    , requestMethod = "GET"+                    }+            sres <- flip runSession app $ request req+            H.statusCode (simpleStatus sres) `shouldBe` 404++    describe "UrlToDispatch (Route site) / Text / String / (Route, params)" $ do+        -- The plain hand-written instances all just forward to yesodDispatch;+        -- pin that they actually dispatch (rather than e.g. always 404). The+        -- url value is ignored by these instances, so we always request /nest.+        let dispatchVia :: UrlToDispatch url App => url -> IO SResponse+            dispatchVia url = do+                yre <- mkYesodRunnerEnv App+                let app = urlToDispatch url yre+                    req = defaultRequest { pathInfo = ["nest"], requestMethod = "GET" }+                flip runSession app $ request req+            expectNest sres = do+                H.statusCode (simpleStatus sres) `shouldBe` 200+                simpleBody sres `shouldBe` "getNestIndexR"+        it "UrlToDispatch (Route site)" $+            dispatchVia (HomeR :: Route App) >>= expectNest+        it "UrlToDispatch (Route site, params)" $+            dispatchVia (HomeR :: Route App, [] :: [(Text, Text)]) >>= expectNest+        it "UrlToDispatch Text" $+            dispatchVia ("ignored" :: Text) >>= expectNest+        it "UrlToDispatch String" $+            dispatchVia ("ignored" :: String) >>= expectNest++    describe "RedirectUrl (WithParentArgs url) Location header" $ do+        -- Pins toTextUrl . toParentRoute: a handler redirecting via a fragment+        -- + parent args must render the same Location as the full route would.+        it "renders the full nested route as the Location" $ do+            app <- toWaiApp App+            sres <- flip runSession app $+                request defaultRequest+                    { pathInfo = ["redirectparent"]+                    , requestMethod = "GET"+                    , httpVersion = H.http11+                    }+            H.statusCode (simpleStatus sres) `shouldBe` 303+            lookup "Location" (simpleHeaders sres)+                `shouldBe` Just "/parent/1/hello/child1"++    describe "RedirectUrl Text / String / (Route, params) Location header" $ do+        -- The unexercised simple RedirectUrl instances, end to end through a+        -- handler redirect.+        it "redirects via plain Text" $ do+            app <- toWaiApp App+            sres <- flip runSession app $+                request defaultRequest+                    { pathInfo = ["redirecttext"]+                    , requestMethod = "GET"+                    , httpVersion = H.http11+                    }+            H.statusCode (simpleStatus sres) `shouldBe` 303+            lookup "Location" (simpleHeaders sres)+                `shouldBe` Just "/some/where"+        it "redirects via plain String" $ do+            app <- toWaiApp App+            sres <- flip runSession app $+                request defaultRequest+                    { pathInfo = ["redirectstring"]+                    , requestMethod = "GET"+                    , httpVersion = H.http11+                    }+            H.statusCode (simpleStatus sres) `shouldBe` 303+            lookup "Location" (simpleHeaders sres)+                `shouldBe` Just "/some/string"+        it "redirects via (Route, params)" $ do+            app <- toWaiApp App+            sres <- flip runSession app $+                request defaultRequest+                    { pathInfo = ["redirectparams"]+                    , requestMethod = "GET"+                    , httpVersion = H.http11+                    }+            H.statusCode (simpleStatus sres) `shouldBe` 303+            lookup "Location" (simpleHeaders sres)+                `shouldBe` Just "/json?q=1"++    describe "RenderRouteNested (WithParentArgs a)" $ do+        it "agrees with renderRoute of the equivalent full Route" $ do+            renderRouteNested () (WithParentArgs (1 :: Int) (Child1R "hello"))+                `shouldBe`+                    renderRoute (toParentRoute (1 :: Int) (Child1R "hello"))+            -- and concretely, the full path:+            renderRouteNested () (WithParentArgs (1 :: Int) (Child1R "hello"))+                `shouldBe`+                    renderRoute (ParentR 1 (Child1R "hello"))+++    describe "selectRep" $ do+        test "application/json" "JSON"+        test (S8.unpack typeJson) "JSON"+        test "text/xml" "XML"+        test (S8.unpack typeXml) "XML"+        test "text/xml,application/json" "XML"+        test "text/xml;q=0.9,application/json;q=1.0" "JSON"+        test (S8.unpack typeHtml) "HTML"+        test "text/html" "HTML"+        test specialHtml "HTMLSPECIAL"+        testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}"+        test "text/*" "HTML"+        test "*/*" "HTML"+    describe "routeAttrs" $ do+        it "HomeR" $ routeAttrs HomeR `shouldBe` Set.singleton "home"+        it "JsonR" $ routeAttrs JsonR `shouldBe` Set.empty+        it "ChildR" $ routeAttrs (ParentR 5 $ Child1R "ignored") `shouldBe` Set.singleton "child"+        -- Bug-2 regression: InnerR is split (RouteAttrsNested InnerR), OuterR is+        -- inlined. The generated clause must carry the OuterR ancestor pattern.+        it "InnerIndexR (split parent under an inlined parent)" $+            routeAttrs (OuterR (InnerR InnerIndexR)) `shouldBe` Set.singleton "innerleaf"++    describe "OuterR (inlined parent delegating to a split InnerR)" $ do+        it "dispatches /outer/inner" $ do+            testRequestIO+                200+                defaultRequest+                    { pathInfo = ["outer", "inner"]+                    , requestMethod = "GET"+                    }+                (Just "getInnerIndexR")++    describe "fallthrough" $ do+        it "is 404 because fallthrough is disabled" $ do+            testRequestIO+                404+                defaultRequest+                    { pathInfo = ["nest", "foo"]+                    , requestMethod = "GET"+                    }+                Nothing++    describe "BlahR" $ do+        -- This test is to verify that you can promote a singleton route-+        -- ie, that+        --+        -- > /blah BlahR GET+        --+        -- and+        --+        -- > /blah BlahR:+        -- >     / BlahIndexR GET+        --+        -- are equivalent+        it "can access with just the prefix" $ do+            testRequestIO+                200+                defaultRequest+                    { pathInfo = ["blah"]+                    , requestMethod = "GET"+                    }+                (Just "getBlahIndexR")++        it "can access a filename route" $ do+            testRequestIO+                200+                defaultRequest+                    { pathInfo = ["robots.txt"]+                    , requestMethod = "GET"+                    }+                (Just "robots.txt")++    describe "ToParentRoute" $ do+        describe "Route App" $ do+            it "works with no args" $ do+                toParentRoute () HomeR `shouldBe` HomeR+            it "works with args" $ do+                toParentRoute () (ParentR 1 (Child1R "hello"))+                    `shouldBe`+                        (ParentR 1 (Child1R "hello"))+        describe "ParentR" $ do+            it "works" $ do+                toParentRoute 3 (Child1R "Hello")+                    `shouldBe`+                        ParentR 3 (Child1R "Hello")++        describe "Parent0R" $ do+            it "works" $ do+                toParentRoute 3 Parent0IndexR+                    `shouldBe`+                        Parent0R 3 Parent0IndexR++            describe "Child0R" $ do+                it "works" $ do+                    toParentRoute (3, "hello") ParentChildIndexR+                        `shouldBe`+                            Parent0R 3 (Child0R "hello" ParentChildIndexR)++                it "works with arg" $ do+                    toParentRoute (3, "hello") (ParentChildR "asdf")+                        `shouldBe`+                            Parent0R 3 (Child0R "hello" (ParentChildR "asdf"))
test/YesodCoreTest/NoOverloadedStrings.hs view
@@ -1,7 +1,13 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeOperators #-}+ module YesodCoreTest.NoOverloadedStrings     ( noOverloadedTest     , Widget@@ -14,7 +20,6 @@ import Yesod.Core import Network.Wai import Network.Wai.Test-import Data.Monoid (mempty) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 @@ -65,7 +70,7 @@ case_sanity :: IO () case_sanity = runner $ do     res <- request defaultRequest-    assertBody Data.Monoid.mempty res+    assertBody mempty res  case_subsite :: IO () case_subsite = runner $ do
test/YesodCoreTest/NoOverloadedStringsSub.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} -- hah, the test should be renamed...+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE OverloadedStrings #-} -- hah, the test should be renamed...+ -- Not actually a problem, we're now requiring overloaded strings, we just need -- to make the docs more explicit about it. module YesodCoreTest.NoOverloadedStringsSub where
+ test/YesodCoreTest/ParamDefaultSplit/Data.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Route data for a delegation-probe regression: a *parameterized* top-level site with a+-- nested route, generated with /default/ opts (i.e. NOT+-- 'setParameterizedSubroute'), so the nested datatype 'SubParentDR' is+-- generated at kind 'Type'. The matching dispatch splice lives in the+-- separately compiled "YesodCoreTest.ParamDefaultSplit.Runtime", so the child+-- datatype is in scope there — the precise shape that made the @go@ delegation+-- probe build the ill-kinded @SubParentDR a@ and abort the splice.+module YesodCoreTest.ParamDefaultSplit.Data where++import Yesod.Core++data PolyD a = PolyD a++mkYesodData "PolyD a" [parseRoutes|+/ HomeDR GET+/item/#Int ItemDR GET+/sub SubParentDR:+    / SubHomeDR GET+    /detail/#Int SubDetailDR GET+|]
+ test/YesodCoreTest/ParamDefaultSplit/Runtime.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Delegation-probe regression: a *parameterized* site (@PolyD a@) with a nested route,+-- using /default/ opts (opted out of nested-route discovery), with the route+-- data and the dispatch splice /split across modules/.+--+-- The dispatch splice's @go@ delegation probe must saturate the in-scope child+-- datatype 'SubParentDR' by its own reified arity (0) — NOT by the site's type+-- args — or it builds the ill-kinded @SubParentDR a@ and @isInstance@ throws a+-- kind error that aborts the splice. So this module compiling at all is the+-- regression assertion; the WAI tests confirm the inlined dispatch still works.+module YesodCoreTest.ParamDefaultSplit.Runtime+    ( specs+    ) where++import Data.Text (Text)+import Test.Hspec+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as H+import Yesod.Core++import YesodCoreTest.ParamDefaultSplit.Data+import YesodCoreTest.RuntimeHarness (assertRequestFor)++mkYesodDispatch "PolyD a" resourcesPolyD++instance Yesod (PolyD a) where+    messageLoggerSource = mempty++getHomeDR :: HandlerFor (PolyD a) Text+getHomeDR = pure "home"++getItemDR :: Int -> HandlerFor (PolyD a) Text+getItemDR _ = pure "item"++getSubHomeDR :: HandlerFor (PolyD a) Text+getSubHomeDR = pure "subHome"++getSubDetailDR :: Int -> HandlerFor (PolyD a) Text+getSubDetailDR _ = pure "subDetail"++sampleRoutes :: [Route (PolyD ())]+sampleRoutes =+    [ HomeDR+    , ItemDR 7+    , SubParentDR SubHomeDR+    , SubParentDR (SubDetailDR 9)+    ]++testRequestIO+    :: HasCallStack+    => Int+    -> [Text]+    -> H.Method+    -> Maybe L.ByteString+    -> IO ()+testRequestIO status path method mexpected =+    assertRequestFor (PolyD ()) method status path mexpected++specs :: Spec+specs = describe "parameterized site, default opts, nested route split across modules" $ do+    describe "parseRoute . renderRoute round-trips" $+        mapM_+            (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r)+            sampleRoutes++    describe "WAI dispatch (inlined, not delegated)" $ do+        it "static leaf (HomeDR)" $+            testRequestIO 200 [] "GET" (Just "home")+        it "dynamic leaf (ItemDR)" $+            testRequestIO 200 ["item", "7"] "GET" (Just "item")+        it "nested parent home (SubParentDR SubHomeDR)" $+            testRequestIO 200 ["sub"] "GET" (Just "subHome")+        it "nested parent dynamic leaf (SubParentDR (SubDetailDR _))" $+            testRequestIO 200 ["sub", "detail", "9"] "GET" (Just "subDetail")+        it "404 on unknown nested suffix" $+            testRequestIO 404 ["sub", "detail", "9", "oops"] "GET" Nothing+        it "405 on wrong method" $+            testRequestIO 405 ["sub"] "POST" Nothing
+ test/YesodCoreTest/ParamFallthroughRuntime.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime coverage for nested-route /fallthrough/ on a *parameterized* site.+-- The monomorphic fallthrough test ("YesodCoreTest.FallthroughDispatch.Runtime")+-- exercises the @setNestedRouteFallthrough@ fallback only for an+-- unparameterized site; this is the parameterized counterpart, opted into+-- nested discovery so the parameterized subroute datatypes carry the type+-- variable while several same-prefix parents fall through to one another.+module YesodCoreTest.ParamFallthroughRuntime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertGet)++data PApp a = PApp a++mkYesodOpts+    (setNestedRouteFallthrough True (setParameterizedSubroute True defaultOpts))+    "PApp a"+    [parseRoutesNoCheck|+/foo   FirstFooR:+    /      FooIndexR+    /neat  FooNeatR++/foo   SecondFooR:+    /       NeverFiresR+    /other  OtherR++/foo/#Int  ParamFooR:+    /  FooWithIntR++/foo/#String TextFooR:+    /  FooWithTextR+|]++instance Yesod (PApp a) where+    messageLoggerSource = mempty++handleFooIndexR :: HandlerFor app String+handleFooIndexR = pure "FooIndexR"++handleOtherR :: HandlerFor app String+handleOtherR = pure "OtherR"++handleFooNeatR :: HandlerFor app String+handleFooNeatR = pure "FooNeatR"++handleNeverFiresR :: HandlerFor app String+handleNeverFiresR = pure "NeverFiresR"++handleFooWithIntR :: Int -> HandlerFor app String+handleFooWithIntR i = pure $ "FooWithIntR " <> show i++handleFooWithTextR :: String -> HandlerFor app String+handleFooWithTextR str = pure $ "FooWithTextR " <> str++testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+testRequestIO = assertGet (PApp ())++specs :: Spec+specs = describe "parameterized site, nested-route fallthrough" $ do+    it "matches the first parent's index (FooIndexR at /foo)" $+        testRequestIO 200 ["foo"] (Just "FooIndexR")+    it "matches a child of the first parent (FooNeatR at /foo/neat)" $+        testRequestIO 200 ["foo", "neat"] (Just "FooNeatR")+    it "falls through to a later same-prefix parent (OtherR at /foo/other)" $+        testRequestIO 200 ["foo", "other"] (Just "OtherR")+    it "falls through to the dynamic-prefix parent (FooWithIntR at /foo/3)" $+        testRequestIO 200 ["foo", "3"] (Just "FooWithIntR 3")+    it "falls through to the textual-prefix parent (FooWithTextR at /foo/asdf)" $+        testRequestIO 200 ["foo", "asdf"] (Just "FooWithTextR asdf")
+ test/YesodCoreTest/ParamFocusSplit/Resources.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Shared route tree + foundation datatype for the parameterized+-- focus-split fixture ("YesodCoreTest.ParamFocusSplit.Runtime" and its+-- @.SubR@ fragment module). The foundation @PApp a@ carries one type+-- argument, so this drives the @TyArgs@-applying focused codegen paths.+module YesodCoreTest.ParamFocusSplit.Resources where++import Yesod.Core+import Yesod.Routes.TH.Types (ResourceTree)++-- | A phantom-parameterized top-level site (kind @Type -> Type@).+data PApp a = PApp++paramFocusResources :: [ResourceTree String]+paramFocusResources = [parseRoutes|+/ HomeR GET+/item/#Int ItemR GET+/sub SubR:+    / SubHomeR GET+    /detail/#Int SubDetailR GET+|]
+ test/YesodCoreTest/ParamFocusSplit/Runtime.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime + round-trip coverage for a *parameterized* top-level site whose+-- nested route block is split into its own module with+-- 'setFocusOnNestedRoute'. Before this fixture the+-- @parameterized + setFocusOnNestedRoute@ corner was never compiled by any+-- test, and the focused 'RouteAttrsNested' instance head was built from a bare+-- constructor (no type argument applied) — a guaranteed kind error for a+-- parameterized site. The parent dispatch is generated here with+-- 'setParameterizedSubroute', so it must *delegate* to the @SubR a@ fragment+-- instances compiled in "YesodCoreTest.ParamFocusSplit.SubR"; the build itself+-- is the split-delegation assertion and the WAI rows confirm dispatch.+module YesodCoreTest.ParamFocusSplit.Runtime+    ( specs+    ) where++import Data.Text (Text)+import Test.Hspec+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as H+import Yesod.Core++import YesodCoreTest.ParamFocusSplit.Resources+-- Brings the split 'SubR' datatype + its nested dispatch / parse / render /+-- attrs instances into scope. Importing the datatype (not @SubR ()@) is what+-- lets the parent splice's delegation probe resolve 'SubR' and delegate to the+-- imported instance instead of regenerating (and demanding) its handlers.+import YesodCoreTest.ParamFocusSplit.SubR (SubR (..))+import YesodCoreTest.RuntimeHarness (assertRequestFor)++-- The parent splice: generates the route data types and the parent dispatch.+-- 'setParameterizedSubroute' forces the NestedDiscovery path so the parent+-- delegates to the split 'SubR' fragment rather than inlining it.+mkYesodOpts (setParameterizedSubroute True defaultOpts) "PApp a" paramFocusResources++instance Yesod (PApp a) where+    messageLoggerSource = mempty++getHomeR :: HandlerFor (PApp a) Text+getHomeR = pure "home"++getItemR :: Int -> HandlerFor (PApp a) Text+getItemR _ = pure "item"++sampleRoutes :: [Route (PApp ())]+sampleRoutes =+    [ HomeR+    , ItemR 7+    , SubR SubHomeR+    , SubR (SubDetailR 9)+    ]++testRequestIO+    :: HasCallStack+    => Int+    -> [Text]+    -> H.Method+    -> Maybe L.ByteString+    -> IO ()+testRequestIO status path method mexpected =+    assertRequestFor (PApp :: PApp ()) method status path mexpected++specs :: Spec+specs = describe "parameterized top-level site, nested routes split with setFocusOnNestedRoute" $ do+    describe "parseRoute . renderRoute round-trips" $+        mapM_+            (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r)+            sampleRoutes++    describe "WAI dispatch (parent delegates to the split SubR fragment)" $ do+        it "static leaf (HomeR)" $+            testRequestIO 200 [] "GET" (Just "home")+        it "dynamic leaf (ItemR)" $+            testRequestIO 200 ["item", "7"] "GET" (Just "item")+        it "nested parent home (delegated SubR SubHomeR)" $+            testRequestIO 200 ["sub"] "GET" (Just "subHome")+        it "nested parent dynamic leaf (delegated SubR (SubDetailR _))" $+            testRequestIO 200 ["sub", "detail", "9"] "GET" (Just "subDetail")+        it "404 on unknown nested suffix" $+            testRequestIO 404 ["sub", "detail", "9", "oops"] "GET" Nothing+        it "405 on wrong method" $+            testRequestIO 405 ["sub"] "POST" Nothing
+ test/YesodCoreTest/ParamFocusSplit/SubR.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The split-out @SubR@ fragment of the parameterized @PApp a@ site. The+-- focused splice ('setFocusOnNestedRoute') here emits only the @SubR a@+-- fragment's dispatch / parse / render / attrs nested instances; the parent+-- "YesodCoreTest.ParamFocusSplit.Runtime" generates the rest and delegates to these.+-- This module is the compile-time pin for the focused parameterized codegen+-- (the @RouteAttrsNested (SubR a)@ instance head in particular, which used to+-- be built from a bare constructor without the site's type argument).+module YesodCoreTest.ParamFocusSplit.SubR where++import Data.Text (Text)+import Yesod.Core+import YesodCoreTest.ParamFocusSplit.Resources++mkYesodOpts+    (setFocusOnNestedRoute "SubR" (setParameterizedSubroute True defaultOpts))+    "PApp a"+    paramFocusResources++getSubHomeR :: HandlerFor (PApp a) Text+getSubHomeR = pure "subHome"++getSubDetailR :: Int -> HandlerFor (PApp a) Text+getSubDetailR _ = pure "subDetail"
+ test/YesodCoreTest/ParamNestedNoFallthroughRuntime.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Exercises the *delegated* (nested-instance) no-fallthrough dispatch path+-- for a 'ResourceParent' child.+--+-- "YesodCoreTest.ParamNoFallthroughRuntime" is two levels deep (parent ->+-- leaf), so the parent's generated @YesodDispatchNested@ instance only ever+-- dispatches to leaf children. This module goes three levels deep+-- (grandparent -> parent -> leaf) under nested discovery (the site carries a+-- type parameter), so the grandparent's nested instance dispatches to the+-- *inner parent* via 'genNestedDispatchClauses' @ResourceParent@ arm — the arm+-- that, with fallthrough disabled, must convert an inner @Nothing@ into a 404+-- commit rather than returning the raw @Maybe@ (which under an outer+-- fallthrough caller would leak through to sibling routes).+module YesodCoreTest.ParamNestedNoFallthroughRuntime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertGet)++data PNNApp a = PNNApp a++-- Three-level nesting, generated WITHOUT setNestedRouteFallthrough. A request+-- that matches the grandparent and inner-parent prefixes but no leaf must+-- commit to a 404 (the inner parent is delegated to via its own nested+-- dispatch instance), never fall through.+mkYesodOpts+    (setParameterizedSubroute True defaultOpts)+    "PNNApp a"+    [parseRoutesNoCheck|+/grand   GrandR:+    /inner  InnerR:+        /leaf   LeafR+        /also   AlsoR+|]++instance Yesod (PNNApp a) where+    messageLoggerSource = mempty++handleLeafR :: HandlerFor app String+handleLeafR = pure "LeafR"++handleAlsoR :: HandlerFor app String+handleAlsoR = pure "AlsoR"++testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+testRequestIO = assertGet (PNNApp ())++specs :: Spec+specs = describe "parameterized site, deep nesting, fallthrough DISABLED" $ do+    it "matches a leaf under the inner parent (/grand/inner/leaf)" $+        testRequestIO 200 ["grand", "inner", "leaf"] (Just "LeafR")+    it "matches the inner parent's other leaf (/grand/inner/also)" $+        testRequestIO 200 ["grand", "inner", "also"] (Just "AlsoR")+    it "404s when the grandparent+parent prefix match but no leaf does (/grand/inner/nope)" $+        -- Drives the delegated ResourceParent no-fallthrough arm: GrandR's+        -- nested instance dispatches to InnerR's nested instance, which returns+        -- Nothing for "nope"; that must become a committed 404.+        testRequestIO 404 ["grand", "inner", "nope"] Nothing+    it "404s when only the grandparent prefix matches (/grand/nope)" $+        testRequestIO 404 ["grand", "nope"] Nothing
+ test/YesodCoreTest/ParamNoExplicitArgs.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Regression pin for invoking @mkYesod@ on a *parameterized* foundation+-- /without/ writing its explicit type argument (here @mkYesod "PNoArgs"@ for+-- @data PNoArgs a@). The reified arity is filled with a fresh type variable,+-- and that fill var must travel in the 'TyArgs' handed to 'discoveryMode' /+-- the generators — otherwise the site is misclassified as monomorphic and+-- emits ill-scoped nested instances (a 1.6 -> 1.7 regression). With the fix it+-- stays on the backwards-compatible inline path. The build is the assertion;+-- the WAI rows confirm it still dispatches.+module YesodCoreTest.ParamNoExplicitArgs+    ( specs+    ) where++import Data.Text (Text)+import Test.Hspec+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as H+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertRequestFor)++-- One type argument, but the splice below names only "PNoArgs" (no @a@).+data PNoArgs a = PNoArgs++-- @CatchAllR@ overlaps @SubParentR@'s prefix (both start with @sub@), so its+-- @!@ turns overlap checking off for it. It is placed AFTER the parent on+-- purpose: under the historical (1.6) inline @parseRoute@ semantics a path that+-- matches the @sub@ prefix but misses every child must COMMIT at the parent and+-- return 'Nothing', NOT fall through to this later, lower-priority sibling. That+-- is exactly what inline @dispatch@ does (404), so @parseRoute@ has to agree.+mkYesod "PNoArgs" [parseRoutes|+/ HomeR GET+/sub SubParentR:+    / SubHomeR GET+!/sub/#Text CatchAllR GET+|]++instance Yesod (PNoArgs a) where+    messageLoggerSource = mempty++getHomeR :: HandlerFor (PNoArgs a) Text+getHomeR = pure "home"++getSubHomeR :: HandlerFor (PNoArgs a) Text+getSubHomeR = pure "subHome"++getCatchAllR :: Text -> HandlerFor (PNoArgs a) Text+getCatchAllR _ = pure "catchAll"++testRequestIO+    :: HasCallStack+    => Int+    -> [Text]+    -> H.Method+    -> Maybe L.ByteString+    -> IO ()+testRequestIO status path method mexpected =+    assertRequestFor (PNoArgs :: PNoArgs ()) method status path mexpected++specs :: Spec+specs = describe "parameterized foundation invoked without explicit type args" $ do+    it "static leaf dispatches" $+        testRequestIO 200 [] "GET" (Just "home")+    it "inlined nested leaf dispatches" $+        testRequestIO 200 ["sub"] "GET" (Just "subHome")+    it "404 on unknown nested suffix (dispatch commits at the parent prefix)" $+        testRequestIO 404 ["sub", "oops"] "GET" Nothing+    it "parseRoute commits at the parent prefix: a child miss is Nothing, not the later overlapping sibling" $+        -- The regression: with overlap checking off the flat inline codegen let+        -- this fall through to @CatchAllR@, so parseRoute returned @Just+        -- (CatchAllR "oops")@ while dispatch returned 404 — they disagreed for+        -- the same request. Commit-on-parent-prefix makes parseRoute agree.+        (parseRoute (["sub", "oops"], []) :: Maybe (Route (PNoArgs ())))+            `shouldBe` Nothing+    it "parseRoute still reaches a matching child under the parent prefix" $+        (parseRoute (["sub"], []) :: Maybe (Route (PNoArgs ())))+            `shouldBe` Just (SubParentR SubHomeR)
+ test/YesodCoreTest/ParamNoFallthroughRuntime.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The negative counterpart to "YesodCoreTest.ParamFallthroughRuntime".+--+-- That module exercises nested-route fallthrough with the flag /enabled/ —+-- every assertion expects fallthrough to succeed. This module builds the same+-- overlapping-@\/foo@ parents *without* 'setNestedRouteFallthrough', and+-- asserts a 404 exactly where the enabled version falls through to a later+-- same-prefix parent. Without this, a regression that made nested fallthrough+-- always-on (ignoring 'roNestedRouteFallthrough') would pass every test.+module YesodCoreTest.ParamNoFallthroughRuntime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertGet)++data PNApp a = PNApp a++-- Same routes as ParamFallthroughRuntime's first two parents, but generated+-- WITHOUT setNestedRouteFallthrough: the first parent that matches the @/foo@+-- prefix is committed to, so a path its children can't match 404s rather than+-- falling through to the next @/foo@ parent.+mkYesodOpts+    (setParameterizedSubroute True defaultOpts)+    "PNApp a"+    [parseRoutesNoCheck|+/foo   FirstFooR:+    /      FooIndexR+    /neat  FooNeatR++/foo   SecondFooR:+    /       NeverFiresR+    /other  OtherR+|]++instance Yesod (PNApp a) where+    messageLoggerSource = mempty++handleFooIndexR :: HandlerFor app String+handleFooIndexR = pure "FooIndexR"++handleFooNeatR :: HandlerFor app String+handleFooNeatR = pure "FooNeatR"++handleNeverFiresR :: HandlerFor app String+handleNeverFiresR = pure "NeverFiresR"++handleOtherR :: HandlerFor app String+handleOtherR = pure "OtherR"++testRequestIO :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+testRequestIO = assertGet (PNApp ())++specs :: Spec+specs = describe "parameterized site, nested-route fallthrough DISABLED" $ do+    it "still matches the first parent's index (FooIndexR at /foo)" $+        testRequestIO 200 ["foo"] (Just "FooIndexR")+    it "still matches a child of the first parent (FooNeatR at /foo/neat)" $+        testRequestIO 200 ["foo", "neat"] (Just "FooNeatR")+    it "404s instead of falling through to a later same-prefix parent (/foo/other)" $+        -- With fallthrough this is OtherR (200); without it, the first /foo+        -- parent commits and its children don't match "other".+        testRequestIO 404 ["foo", "other"] Nothing
+ test/YesodCoreTest/ParamSubsite/Data.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++-- | Opt-in counterpart to "YesodCoreTest.ParameterizedSubData": this subsite+-- enables parameterized subroutes via+-- @'mkYesodSubDataOpts' ('setParameterizedSubroute' 'True' ...)@. With the+-- flag on, the nested subroute datatype 'PNestedR' carries the subsite's type+-- parameter (kind @Type -> Type@), so the threaded constraints / associated+-- type families stay well-scoped. This proves that opting a /subsite/ into+-- parameterized subroutes actually parameterizes its subroutes.+module YesodCoreTest.ParamSubsite.Data where++import Yesod.Core++type RouteConstraints t = (Eq t, Read t, Show t, PathPiece t)++class (RouteConstraints (PAssoc subsite)) => PClass subsite master | subsite -> master where+  type PAssoc subsite+  pValue :: subsite -> master -> String++newtype PSub subsite = PSub subsite++mkYesodSubDataOpts (setParameterizedSubroute True defaultOpts)+  "(PClass subsite master) => PSub subsite" [parseRoutes|+/ PHomeR GET+/item/#Int PItemR GET+!/#{PAssoc subsite}/nested PNestedR:+    / PNestedHomeR GET+    /detail/#Int PNestedDetailR GET+|]++-- | Opt-in kind guard: with parameterized subroutes enabled, the nested+-- subroute datatype is parameterized over the subsite. This signature only+-- compiles if 'PNestedR' has kind @Type -> Type@.+_pNestedRParamGuard :: PNestedR subsite -> PNestedR subsite+_pNestedRParamGuard = id
+ test/YesodCoreTest/ParamSubsite/InstanceRuntime.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime coverage for 'mkYesodSubDispatchInstance' (the public convenience+-- that generates both the @YesodSubDispatch@ instance and the+-- @YesodSubDispatchNested@ instances for a parameterized subsite). The+-- function had **no** in-repo test before; this exercises the happy path —+-- a parameterized subsite whose subroutes are parameterized+-- ('setParameterizedSubroute') — end to end (compile + WAI dispatch + route+-- round-trip).+--+-- The misuse case (parameterized subsite + unparameterized nested datatype)+-- is a compile error by design, so it is covered by the pure unit test for+-- 'checkNestedSubArity' in @Route.SubDispatchAritySpec@ rather than here.+module YesodCoreTest.ParamSubsite.InstanceRuntime+    ( specs+    ) where++import Data.Text (Text)+import Test.Hspec+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as H+import Yesod.Core+import Yesod.Core.Dispatch (toWaiApp, mkYesodSubDispatchInstance)++import YesodCoreTest.ParamSubsite.Data+import YesodCoreTest.RuntimeHarness (assertRequestFor)++-- | Concrete instantiation of the parameterized subsite.+data ConcretePSub = ConcretePSub++instance PClass ConcretePSub App where+    type PAssoc ConcretePSub = Text+    pValue _ _ = "value"++type ConcretePSubT = PSub ConcretePSub++data App = App++-- Handlers for the subsite. The nested handlers receive the parent's+-- 'PAssoc' dynamic, exactly as for any other nested route.+getPHomeR :: SubHandlerFor (PSub subsite) master Text+getPHomeR = pure "pHome"++getPItemR :: Int -> SubHandlerFor (PSub subsite) master Text+getPItemR _ = pure "pItem"++getPNestedHomeR :: PAssoc subsite -> SubHandlerFor (PSub subsite) master Text+getPNestedHomeR _ = pure "pNestedHome"++getPNestedDetailR :: PAssoc subsite -> Int -> SubHandlerFor (PSub subsite) master Text+getPNestedDetailR _ _ = pure "pNestedDetail"++-- The API under test: generate the YesodSubDispatch + YesodSubDispatchNested+-- instances for the parameterized subsite. Placed before 'mkYesod' so the+-- master dispatch can see the generated subsite instances.+mkYesodSubDispatchInstance "(PClass subsite master) => PSub subsite" resourcesPSub++mkYesod "App" [parseRoutes|+/ HomeR GET+/p PSubR ConcretePSubT getP+|]++instance Yesod App where+    messageLoggerSource = mempty++getHomeR :: Handler Text+getHomeR = pure "home"++getP :: App -> ConcretePSubT+getP _ = PSub ConcretePSub++sampleRoutes :: [Route ConcretePSubT]+sampleRoutes =+    [ PHomeR+    , PItemR 7+    , PNestedR "abc" PNestedHomeR+    , PNestedR "abc" (PNestedDetailR 9)+    ]++testRequestIO+    :: HasCallStack+    => Int+    -> [Text]+    -> H.Method+    -> Maybe L.ByteString+    -> IO ()+testRequestIO status path method mexpected =+    assertRequestFor App method status path mexpected++specs :: Spec+specs = describe "mkYesodSubDispatchInstance (parameterized subsite, opt-in subroutes)" $ do+    describe "parseRoute . renderRoute round-trips" $+        mapM_+            (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r)+            sampleRoutes++    describe "WAI dispatch (subsite mounted at /p)" $ do+        it "static leaf (PHomeR)" $+            testRequestIO 200 ["p"] "GET" (Just "pHome")+        it "dynamic leaf (PItemR)" $+            testRequestIO 200 ["p", "item", "7"] "GET" (Just "pItem")+        it "nested parent home (PNestedR _ PNestedHomeR)" $+            testRequestIO 200 ["p", "abc", "nested"] "GET" (Just "pNestedHome")+        it "nested parent dynamic leaf (PNestedR _ (PNestedDetailR _))" $+            testRequestIO 200 ["p", "abc", "nested", "detail", "9"] "GET" (Just "pNestedDetail")+        it "404 on unknown nested suffix" $+            testRequestIO 404 ["p", "abc", "nested", "oops"] "GET" Nothing+        it "405 on wrong method" $+            testRequestIO 405 ["p", "abc", "nested"] "POST" Nothing
+ test/YesodCoreTest/ParamSubsite/SplitNested.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Split-out dispatch module for the *parameterized* subsite's nested+-- 'PNestedR' fragment. This is the parameterized counterpart to+-- "YesodCoreTest.SplitSubsite.NestedR": the subsite carries a type parameter,+-- so the subroute datatype 'PNestedR' is itself parameterized (kind+-- @Type -> Type@), and the subsite's type argument must be threaded through+-- 'mkNestedSubDispatchInstance' as 'SomeTyArgs'.+--+-- Crucially, the nested handlers ('getPNestedHomeR', 'getPNestedDetailR') live+-- ONLY here, not in the module that defines the parent 'YesodSubDispatch'+-- instance. So that parent splice can compile only by *delegating* to the+-- 'YesodSubDispatchNested' instance generated here (via 'isInstance') — if it+-- tried to inline the nested routes it would reference handlers not in scope.+-- A successful build is therefore proof that the cross-module split works for+-- a parameterized subsite, exercising the @SomeTyArgs@ / @applyTyArgs@ branches+-- of the dispatch codegen that were previously untested.+module YesodCoreTest.ParamSubsite.SplitNested () where++import Yesod.Core+import Yesod.Core.Dispatch+    (mkNestedSubDispatchInstance, TyArgs(..))+import Language.Haskell.TH (Type(..), mkName)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Text (Text)++import YesodCoreTest.ParamSubsite.Data++getPNestedHomeR :: PAssoc subsite -> SubHandlerFor (PSub subsite) master Text+getPNestedHomeR _ = pure "pNestedHome"++getPNestedDetailR :: PAssoc subsite -> Int -> SubHandlerFor (PSub subsite) master Text+getPNestedDetailR _ _ = pure "pNestedDetail"++-- Generate @YesodSubDispatchNested (PNestedR subsite)@ in this separate module,+-- with the subsite's type argument applied.+--+-- The 'Cxt' and 'TyArgs' are built manually (rather than parsed from a string+-- like @"(PClass subsite master) => PSub subsite"@) because structured+-- arguments are 'mkNestedSubDispatchInstance''s interface: the string parser+-- belongs to 'mkYesodSubDispatchInstance', the whole-subsite entry point,+-- which does this same construction internally after parsing. A split-out+-- fragment module addresses one nested datatype directly, so it supplies the+-- pieces directly; what is written here is exactly what the parent entry+-- point would thread through for that name string.+$(do+    let subsite = mkName "subsite"+        master  = mkName "master"+        cxt    = [ ConT (mkName "PClass") `AppT` VarT subsite `AppT` VarT master ]+        tyargs = SomeTyArgs ((VarT subsite, subsite) :| [])+    mkNestedSubDispatchInstance+        (setParameterizedSubroute True defaultOpts)+        "PNestedR"+        cxt+        tyargs+        return+        resourcesPSub)
+ test/YesodCoreTest/ParamSubsite/SplitRuntime.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime coverage for a *parameterized* subsite whose nested routes are+-- /split across modules/ — the combination that had no test before (split was+-- monomorphic-only; parameterized nested-discovery was single-module-only).+--+-- The parent @YesodSubDispatch (PSub subsite) master@ instance is generated+-- here with 'mkYesodSubDispatch', but the nested 'PNestedR' handlers and its+-- 'YesodSubDispatchNested' instance live in the separately compiled+-- "YesodCoreTest.ParamSubsite.SplitNested". Because those handlers are NOT in scope+-- here, this module compiles only if the parent splice *delegates* to the+-- external nested instance rather than inlining it — so the build itself is+-- the split-delegation assertion, and the WAI tests confirm it dispatches.+module YesodCoreTest.ParamSubsite.SplitRuntime+    ( specs+    ) where++import Data.Text (Text)+import Test.Hspec+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as H+import Yesod.Core++import YesodCoreTest.ParamSubsite.Data+import YesodCoreTest.ParamSubsite.SplitNested ()  -- brings the split nested instance into scope+import YesodCoreTest.RuntimeHarness (assertRequestFor)++-- | Concrete instantiation of the parameterized subsite.+data ConcretePSub = ConcretePSub++instance PClass ConcretePSub App where+    type PAssoc ConcretePSub = Text+    pValue _ _ = "value"++type ConcretePSubT = PSub ConcretePSub++data App = App++-- Only the FLAT subsite handlers live here; the nested ones are deliberately+-- absent (see module haddock).+getPHomeR :: SubHandlerFor (PSub subsite) master Text+getPHomeR = pure "pHome"++getPItemR :: Int -> SubHandlerFor (PSub subsite) master Text+getPItemR _ = pure "pItem"++-- The parent dispatch. Generated in THIS module (separately from the nested+-- 'PNestedR' instance), so its 'mkYesodSubDispatch' splice must delegate to the+-- imported 'YesodSubDispatchNested (PNestedR subsite)' instance.+instance PClass subsite master => YesodSubDispatch (PSub subsite) master where+    yesodSubDispatch = $(mkYesodSubDispatch resourcesPSub)++mkYesod "App" [parseRoutes|+/ HomeR GET+/p PSubR ConcretePSubT getP+|]++instance Yesod App where+    messageLoggerSource = mempty++getHomeR :: Handler Text+getHomeR = pure "home"++getP :: App -> ConcretePSubT+getP _ = PSub ConcretePSub++sampleRoutes :: [Route ConcretePSubT]+sampleRoutes =+    [ PHomeR+    , PItemR 7+    , PNestedR "abc" PNestedHomeR+    , PNestedR "abc" (PNestedDetailR 9)+    ]++testRequestIO+    :: HasCallStack+    => Int+    -> [Text]+    -> H.Method+    -> Maybe L.ByteString+    -> IO ()+testRequestIO status path method mexpected =+    assertRequestFor App method status path mexpected++specs :: Spec+specs = describe "parameterized subsite, nested routes split across modules" $ do+    describe "parseRoute . renderRoute round-trips" $+        mapM_+            (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r)+            sampleRoutes++    describe "WAI dispatch (parent delegates to the split nested instance)" $ do+        it "static leaf (PHomeR)" $+            testRequestIO 200 ["p"] "GET" (Just "pHome")+        it "dynamic leaf (PItemR)" $+            testRequestIO 200 ["p", "item", "7"] "GET" (Just "pItem")+        it "nested parent home (delegated PNestedHomeR)" $+            testRequestIO 200 ["p", "abc", "nested"] "GET" (Just "pNestedHome")+        it "nested parent dynamic leaf (delegated PNestedDetailR)" $+            testRequestIO 200 ["p", "abc", "nested", "detail", "9"] "GET" (Just "pNestedDetail")+        it "404 on unknown nested suffix" $+            testRequestIO 404 ["p", "abc", "nested", "oops"] "GET" Nothing+        it "405 on wrong method" $+            testRequestIO 405 ["p", "abc", "nested"] "POST" Nothing
+ test/YesodCoreTest/ParamTopLevelRuntime.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime coverage for a *top-level* parameterized site that opts into+-- nested route discovery ('setParameterizedSubroute'). Existing coverage of+-- this combination ("YesodCoreTest.ParameterizedSite.SubRoute") only fires a+-- single request per route and never round-trips or checks error statuses;+-- this exercises the same opt-in top-level path with full+-- @parseRoute . renderRoute@ round-trips plus 404/405 cases.+module YesodCoreTest.ParamTopLevelRuntime+    ( specs+    ) where++import Data.Text (Text)+import Test.Hspec+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as H+import Yesod.Core++import YesodCoreTest.RuntimeHarness (assertRequestFor)++-- A phantom-parameterized top-level site. With 'setParameterizedSubroute'+-- enabled, the nested subroute datatype 'SubParentR' carries the parameter+-- (kind @Type -> Type@), so this drives the NestedDiscovery codegen path.+data Poly a = Poly a++mkYesodOpts (setParameterizedSubroute True defaultOpts) "Poly a" [parseRoutes|+/ HomeR GET+/item/#Int ItemR GET+/sub SubParentR:+    / SubHomeR GET+    /detail/#Int SubDetailR GET+|]++instance Yesod (Poly a) where+    messageLoggerSource = mempty++getHomeR :: HandlerFor (Poly a) Text+getHomeR = pure "home"++getItemR :: Int -> HandlerFor (Poly a) Text+getItemR _ = pure "item"++getSubHomeR :: HandlerFor (Poly a) Text+getSubHomeR = pure "subHome"++getSubDetailR :: Int -> HandlerFor (Poly a) Text+getSubDetailR _ = pure "subDetail"++sampleRoutes :: [Route (Poly ())]+sampleRoutes =+    [ HomeR+    , ItemR 7+    , SubParentR SubHomeR+    , SubParentR (SubDetailR 9)+    ]++testRequestIO+    :: HasCallStack+    => Int+    -> [Text]+    -> H.Method+    -> Maybe L.ByteString+    -> IO ()+testRequestIO status path method mexpected =+    assertRequestFor (Poly ()) method status path mexpected++specs :: Spec+specs = describe "top-level parameterized site, opted into nested discovery" $ do+    describe "parseRoute . renderRoute round-trips" $+        mapM_+            (\r -> it (show r) $ parseRoute (renderRoute r) `shouldBe` Just r)+            sampleRoutes++    describe "WAI dispatch" $ do+        it "static leaf (HomeR)" $+            testRequestIO 200 [] "GET" (Just "home")+        it "dynamic leaf (ItemR)" $+            testRequestIO 200 ["item", "7"] "GET" (Just "item")+        it "nested parent home (SubParentR SubHomeR)" $+            testRequestIO 200 ["sub"] "GET" (Just "subHome")+        it "nested parent dynamic leaf (SubParentR (SubDetailR _))" $+            testRequestIO 200 ["sub", "detail", "9"] "GET" (Just "subDetail")+        it "404 on unknown nested suffix" $+            testRequestIO 404 ["sub", "detail", "9", "oops"] "GET" Nothing+        it "405 on wrong method" $+            testRequestIO 405 ["sub"] "POST" Nothing
+ test/YesodCoreTest/ParameterizedSite.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module YesodCoreTest.ParameterizedSite+    ( parameterizedSiteTest+    ) where++import Data.ByteString.Lazy (ByteString)+import Network.Wai.Test (runSession, request, defaultRequest, assertBodyContains, setPath)+import Test.Hspec (Spec, describe, it)+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+parameterizedSiteTest = describe "Polymorphic Yesod sites" $ do+    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 =+    let actions = do+            res <- request defaultRequest+            assertBodyContains "Stub" res+    in toWaiApp stub >>= runSession actions+++runStub' :: YesodDispatch a => ByteString -> a -> IO ()+runStub' body stub =+    let actions = do+            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/Compat.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module YesodCoreTest.ParameterizedSite.Compat+    ( Compat (..)+    ) where++import Yesod.Core++-- | Parameterized without constraints, and we call mkYesod without type vars,+-- like people used to do before the last 3 commits+data Compat a b = Compat a b++mkYesod "Compat" [parseRoutes|+/ HomeR GET+|]++instance Yesod (Compat a b)++getHomeR :: Handler a b Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Stub+    |]
+ test/YesodCoreTest/ParameterizedSite/PolyAny.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module YesodCoreTest.ParameterizedSite.PolyAny+    ( PolyAny (..)+    ) where++import Yesod.Core++-- | Parameterized without constraints+data PolyAny a = PolyAny a++mkYesod "PolyAny a" [parseRoutes|+/ HomeR GET+|]++instance Yesod (PolyAny a)++getHomeR :: Handler a Html+getHomeR = defaultLayout+    [whamlet|+        <p>+            Stub+    |]
+ test/YesodCoreTest/ParameterizedSite/PolyShow.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module YesodCoreTest.ParameterizedSite.PolyShow+    ( PolyShow (..)+    ) where++import Yesod.Core++-- | Parameterized with 'Show' constraint+data PolyShow a = PolyShow a++mkYesod "(Show a) => PolyShow a" [parseRoutes|+/ HomeR GET+|]++instance Show a => Yesod (PolyShow a)++getHomeR :: Show a => Handler a Html+getHomeR = do+    PolyShow x <- getYesod+    defaultLayout+        [whamlet|+            <p>+                Stub #{show x}+        |]
+ test/YesodCoreTest/ParameterizedSite/SubRoute.hs view
@@ -0,0 +1,80 @@+{-# 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.+-}++-- | Opt-in guard (the counterpart to the backwards-compat guard in+-- "YesodCoreTest.ParameterizedSubDispatch"). With 'setParameterizedSubroute'+-- enabled, the nested subroute datatype /does/ carry the parent's type+-- parameters — here 'EditorR' has kind @Type -> Type -> Type@ — so the+-- threaded constraints stay well-scoped. This signature only compiles if the+-- opt-in still parameterizes the subroute, proving the nested-discovery+-- feature remains available behind the flag.+_editorRParamGuard :: EditorR p v -> EditorR p v+_editorRParamGuard = id++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}+        |]
+ test/YesodCoreTest/ParameterizedSubData.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FunctionalDependencies #-}+-- ^ Useful for debugging generated code; can be removed once stable++-- | Test case for mkYesodSubData and mkYesodSubDispatch with+-- parameterized/constrained types. Reproduces bugs reported by+-- l0neGamer on PR #1887:+--+-- 1. mkYesodSubData with a constrained type like+--    @"(SomeClass subsite master) => SubsiteData subsite"@+--    where 'master' appears in the context but NOT as a type parameter+--    of the subsite, produces "Out of scope type variable" errors in+--    family instances.+--+-- 2. mkYesodSubDispatch with the same setup produces "Expecting one+--    more argument to 'NestedR'" because isInstance checks and Proxy+--    types weren't fully applied. See ParameterizedSubDispatch.hs.+module YesodCoreTest.ParameterizedSubData where++import Yesod.Core++type RouteConstraints t = (Eq t, Read t, Show t, PathPiece t)++-- | A multi-param type class where 'master' is NOT a parameter of the+-- subsite type, mimicking the pattern:+--   @mkYesodSubData "(SubsiteClass subsite master) => SubsiteData subsite"@+-- The fundep ensures 'master' is determined by 'subsite', which is+-- typical for real-world subsite classes.+class (RouteConstraints (AssocType subsite)) => ParamSubsiteClass subsite master | subsite -> master where+  type AssocType subsite+  getSubsiteValue :: subsite -> master -> String++newtype ParamSubsite subsite = ParamSubsite subsite++mkYesodSubData "(ParamSubsiteClass subsite master) => ParamSubsite subsite" [parseRoutes|+/ ParamSubHomeR GET+/item/#Int ParamSubItemR GET+!/#{AssocType subsite}/nested NestedR:+    / NestedHomeR GET+    /detail/#Int NestedDetailR GET+|]
+ test/YesodCoreTest/ParameterizedSubDispatch.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Test mkYesodSubDispatch with parameterized/constrained types.+-- This exercises the Dispatch TH code path for parameterized subsites.+--+-- Tests two subsites:+-- 1. ParamSubDispatch (from Data submodule) - simple parameterized subsite+-- 2. ParamSubsite (from ParameterizedSubData) - with associated types,+--    dynamic pieces in nested route parents, and ConstraintKinds+module YesodCoreTest.ParameterizedSubDispatch where++import Yesod.Core+import Data.Text (Text)+import YesodCoreTest.ParameterizedSubDispatch.Data+import YesodCoreTest.ParameterizedSubData++-- Handlers for ParamSubDispatch (simple parameterized subsite)+getParamDispHomeR :: SubHandlerFor (ParamSubDispatch subsite) master Text+getParamDispHomeR = pure "home"++getParamDispItemR :: Int -> SubHandlerFor (ParamSubDispatch subsite) master Text+getParamDispItemR _ = pure "item"++instance ParamSubDispatchClass subsite master => YesodSubDispatch (ParamSubDispatch subsite) master where+    yesodSubDispatch = $(mkYesodSubDispatch resourcesParamSubDispatch)++-- Handlers for ParamSubsite (with associated types and nested routes)+getParamSubHomeR :: SubHandlerFor (ParamSubsite subsite) master Text+getParamSubHomeR = pure "paramSubHome"++getParamSubItemR :: Int -> SubHandlerFor (ParamSubsite subsite) master Text+getParamSubItemR _ = pure "paramSubItem"++getNestedHomeR :: AssocType subsite -> SubHandlerFor (ParamSubsite subsite) master Text+getNestedHomeR _ = pure "nestedHome"++getNestedDetailR :: AssocType subsite -> Int -> SubHandlerFor (ParamSubsite subsite) master Text+getNestedDetailR _ _ = pure "nestedDetail"++instance+  ( ParamSubsiteClass subsite master+  ) => YesodSubDispatch (ParamSubsite subsite) master where+  yesodSubDispatch = $(mkYesodSubDispatch resourcesParamSubsite)++-- | Backwards-compatibility guard for the reported regression.+--+-- By default ('defaultOpts', as used by 'mkYesodSubData'), nested subroute+-- datatypes must remain *unparameterized* — kind 'Type' — exactly as+-- pre-nested-discovery Yesod generated them. The reported breakage was that+-- the branch silently gave them the parent's type parameter (kind+-- @Type -> Type@), which broke any downstream type signature mentioning the+-- subroute.+--+-- This signature only compiles if 'NestedR' has kind 'Type'. If the default+-- ever regresses to parameterizing subroutes, 'NestedR' would have kind+-- @Type -> Type@ and this would fail with a kind error — turning the+-- downstream breakage into a local, in-repo test failure.+_nestedRArityGuard :: NestedR -> NestedR+_nestedRArityGuard = id
+ test/YesodCoreTest/ParameterizedSubDispatch/Data.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- | Route data for a parameterized subsite used by+-- ParameterizedSubDispatch to test mkYesodSubDispatch.+module YesodCoreTest.ParameterizedSubDispatch.Data where++import Yesod.Core++class ParamSubDispatchClass subsite master | subsite -> master where+  getDispatchValue :: subsite -> master -> String++data ParamSubDispatch subsite = ParamSubDispatch subsite++mkYesodSubData "(ParamSubDispatchClass subsite master) => ParamSubDispatch subsite" [parseRoutes|+/ ParamDispHomeR GET+/item/#Int ParamDispItemR GET+|]
+ test/YesodCoreTest/ParameterizedSubDispatchRuntime.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime coverage for the backwards-compatible (opt-out) inline+-- nested-route codegen.+--+-- The modules "YesodCoreTest.ParameterizedSubData" /+-- "YesodCoreTest.ParameterizedSubDispatch" only exercise the parameterized+-- /opt-out/ path at *compile time* (data + dispatch instances, no runtime+-- assertions). This module gives the same shape a concrete instantiation and+-- actually exercises it at runtime:+--+--   * 'parseRoute' . 'renderRoute' round-trips for every constructor, and+--   * WAI dispatch returns the right status + body for each path,+--+-- covering the static, dynamic, and (dynamically-keyed) nested-parent inline+-- arms — the path-piece ordering, parent-constructor nesting and @dyns@+-- handling that previously had no runtime guard.+module YesodCoreTest.ParameterizedSubDispatchRuntime+    ( specs+    ) where++import Data.Text (Text)+import Test.Hspec+import qualified Data.ByteString.Lazy as L+import qualified Network.HTTP.Types as H+import Yesod.Core+import Yesod.Core.Dispatch (toWaiApp)++import YesodCoreTest.ParameterizedSubData+import YesodCoreTest.ParameterizedSubDispatch ()+import YesodCoreTest.ParameterizedSubDispatchRuntime.Data+import YesodCoreTest.RuntimeHarness (assertRequestFor)++-- | A concrete subsite for 'ParamSubsite'. Its associated 'AssocType' is+-- 'Text', so the dynamically-keyed nested parent (@!/#{AssocType subsite}@)+-- becomes a plain @Text@ path piece at runtime.+data ConcreteSub = ConcreteSub++instance ParamSubsiteClass ConcreteSub App where+    type AssocType ConcreteSub = Text+    getSubsiteValue _ _ = "concrete"++-- | parseRoutes can only embed a single-token subsite type, so we alias the+-- fully-applied subsites here.+type ConcreteParamSub = ParamSubsite ConcreteSub+type ConcreteBigSub = BigSub ()++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+/sub ParamSubR ConcreteParamSub getSub+/big BigSubR ConcreteBigSub getBig+|]++instance Yesod App where+    messageLoggerSource = mempty++getHomeR :: Handler Text+getHomeR = pure "home"++getSub :: App -> ConcreteParamSub+getSub _ = ParamSubsite ConcreteSub++getBig :: App -> ConcreteBigSub+getBig _ = BigSub ()++-- Dispatch + handlers for the BigSub / ChildSub subsites.+instance YesodSubDispatch (BigSub a) master where+    yesodSubDispatch = $(mkYesodSubDispatch resourcesBigSub)++instance YesodSubDispatch ChildSub master where+    yesodSubDispatch = $(mkYesodSubDispatch resourcesChildSub)++getBigItemR :: Int -> SubHandlerFor (BigSub a) master Text+getBigItemR _ = pure "bigItem"++getBigMultiR :: [Text] -> SubHandlerFor (BigSub a) master Text+getBigMultiR _ = pure "bigMulti"++getWrapHomeR :: Int -> SubHandlerFor (BigSub a) master Text+getWrapHomeR _ = pure "wrapHome"++getWrapDetailR :: Int -> Int -> SubHandlerFor (BigSub a) master Text+getWrapDetailR _ _ = pure "wrapDetail"++getChildHomeR :: SubHandlerFor ChildSub master Text+getChildHomeR = pure "childHome"++getChildXR :: Int -> SubHandlerFor ChildSub master Text+getChildXR _ = pure "childX"++-- | Every constructor of the parameterized subsite's route, instantiated at+-- the concrete subsite.+sampleRoutes :: [Route ConcreteParamSub]+sampleRoutes =+    [ ParamSubHomeR+    , ParamSubItemR 7+    , NestedR "abc" NestedHomeR+    , NestedR "abc" (NestedDetailR 9)+    ]++-- | Routes for 'BigSub', covering a multipiece leaf and a subsite leaf nested+-- under a 'ResourceParent'.+bigSampleRoutes :: [Route ConcreteBigSub]+bigSampleRoutes =+    [ BigItemR 3+    , BigMultiR ["a", "b", "c"]+    , BigMultiR []+    , WrapR 5 WrapHomeR+    , WrapR 5 (WrapDetailR 9)+    , EmbedParentR (ChildR ChildHomeR)+    , EmbedParentR (ChildR (ChildXR 9))+    ]++testRequestIO+    :: HasCallStack+    => Int               -- ^ expected http status code+    -> [Text]            -- ^ pathInfo+    -> H.Method          -- ^ request method+    -> Maybe L.ByteString -- ^ expected body (Nothing = don't check)+    -> IO ()+testRequestIO status path method mexpected =+    assertRequestFor App method status path mexpected++specs :: Spec+specs = describe "opt-out (backwards-compat) parameterized nested routes" $ do+    describe "parseRoute . renderRoute round-trips" $ do+        mapM_+            (\r -> it (show r) $+                parseRoute (renderRoute r) `shouldBe` Just r)+            sampleRoutes+        mapM_+            (\r -> it (show r) $+                parseRoute (renderRoute r) `shouldBe` Just r)+            bigSampleRoutes++    describe "WAI dispatch (subsite mounted at /sub)" $ do+        it "static leaf (ParamSubHomeR)" $+            testRequestIO 200 ["sub"] "GET" (Just "paramSubHome")+        it "dynamic leaf (ParamSubItemR)" $+            testRequestIO 200 ["sub", "item", "7"] "GET" (Just "paramSubItem")+        it "nested parent home (NestedR _ NestedHomeR)" $+            testRequestIO 200 ["sub", "abc", "nested"] "GET" (Just "nestedHome")+        it "nested parent dynamic leaf (NestedR _ (NestedDetailR _))" $+            testRequestIO 200 ["sub", "abc", "nested", "detail", "9"] "GET" (Just "nestedDetail")+        it "404 on unknown nested suffix" $+            testRequestIO 404 ["sub", "abc", "nested", "oops"] "GET" Nothing+        it "405 on wrong method for nested leaf" $+            testRequestIO 405 ["sub", "abc", "nested"] "POST" Nothing+        it "404 on malformed dynamic leaf piece (#Int given non-integer)" $+            testRequestIO 404 ["sub", "item", "notanint"] "GET" Nothing+        it "404 on malformed dynamic nested-leaf piece (NestedDetailR #Int)" $+            testRequestIO 404 ["sub", "abc", "nested", "detail", "notanint"] "GET" Nothing++    describe "WAI dispatch (BigSub mounted at /big)" $ do+        it "dynamic leaf (BigItemR)" $+            testRequestIO 200 ["big", "item", "3"] "GET" (Just "bigItem")+        it "multipiece leaf (BigMultiR)" $+            testRequestIO 200 ["big", "multi", "a", "b", "c"] "GET" (Just "bigMulti")+        it "multipiece leaf, empty tail (BigMultiR [])" $+            testRequestIO 200 ["big", "multi"] "GET" (Just "bigMulti")+        it "nested parent home (WrapR _ WrapHomeR)" $+            testRequestIO 200 ["big", "wrap", "5"] "GET" (Just "wrapHome")+        it "nested parent dynamic leaf (WrapR _ (WrapDetailR _))" $+            testRequestIO 200 ["big", "wrap", "5", "detail", "9"] "GET" (Just "wrapDetail")+        it "subsite leaf nested under parent, home (EmbedParentR (ChildR ChildHomeR))" $+            testRequestIO 200 ["big", "embed", "sub"] "GET" (Just "childHome")+        it "subsite leaf nested under parent, dynamic (EmbedParentR (ChildR (ChildXR _)))" $+            testRequestIO 200 ["big", "embed", "sub", "x", "9"] "GET" (Just "childX")+        it "404 on malformed dynamic parent key (WrapR #Int given non-integer)" $+            testRequestIO 404 ["big", "wrap", "notanint"] "GET" Nothing
+ test/YesodCoreTest/ParameterizedSubDispatchRuntime/Data.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Route data for the runtime opt-out coverage in+-- "YesodCoreTest.ParameterizedSubDispatchRuntime". Kept in its own module so+-- the 'mkYesodSubDispatch' splices there can refer to the @resources*@ values+-- generated here (TH stage restriction).+module YesodCoreTest.ParameterizedSubDispatchRuntime.Data where++import Yesod.Core+import Data.Text (Text)++-- | A monomorphic leaf subsite, embedded under a 'ResourceParent' of 'BigSub'+-- to exercise the inline @Subsite@ arm+-- ('generateParseRouteClausesInline' in Yesod.Routes.TH.ParseRoute).+data ChildSub = ChildSub++mkYesodSubData "ChildSub" [parseRoutes|+/ ChildHomeR GET+/x/#Int ChildXR GET+|]++-- | A parameterized (hence opt-out) subsite that covers a multipiece leaf and+-- a subsite leaf nested under a 'ResourceParent'. The type parameter @a@ is+-- phantom — its only job is to make @tyargs@ non-empty so the+-- backwards-compatible inline path is taken.+newtype BigSub a = BigSub a++mkYesodSubData "BigSub a" [parseRoutes|+/item/#Int BigItemR GET+/multi/+[Text] BigMultiR GET+/wrap/#Int WrapR:+    / WrapHomeR GET+    /detail/#Int WrapDetailR GET+/embed EmbedParentR:+    /sub ChildR ChildSub getChildSub+|]++getChildSub :: BigSub a -> ChildSub+getChildSub _ = ChildSub
test/YesodCoreTest/RawResponse.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.RawResponse     ( specs     , Widget
test/YesodCoreTest/Redirect.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.Redirect     ( specs     , Widget
+ test/YesodCoreTest/RenderRouteSpec.hs view
@@ -0,0 +1,51 @@+{-# language CPP #-}+{-# language TemplateHaskell #-}+{-# language TypeApplications #-}+{-# language OverloadedStrings #-}+{-# language TypeFamilies #-}+{-# language ViewPatterns #-}++-- | Behavioural @renderRoute@ spec built from a hand-constructed+-- 'ResourceTree' AST (a @ResourceParent@ with one dynamic piece over a leaf)+-- rather than @parseRoutes@, so it pins @mkRenderRouteInstanceOpts@ directly+-- against a known tree. Companion module "YesodCoreTest.RenderRouteSpec.TH"+-- reuses the generated instance from a compile-time splice.+module YesodCoreTest.RenderRouteSpec where++import Yesod.Routes.TH.Types+import Language.Haskell.TH+import Yesod.Routes.TH.RenderRoute+import Yesod.Routes.Class+import Test.Hspec++data App = App++-- Generate the 'RenderRoute' instance for 'App' at compile time, then check+-- 'renderRoute' behaves at runtime (the prod path; the intermediate clause+-- lists are not asserted directly).+do+    let int = ConT ''Int+    mkRenderRouteInstanceOpts defaultOpts [] NoTyArgs (ConT (mkName "App"))+            [ ResourceParent "FirstR" False mempty [Static "first", Dynamic int]+                [ ResourceLeaf Resource+                    { resourceName = "BlahR"+                    , resourcePieces = [Static "blah"]+                    , resourceDispatch = Methods+                        { methodsMulti = Nothing+                        , methodsMethods = []+                        }+                    , resourceAttrs = []+                    , resourceCheck = False+                    }+                ]+            ]++spec :: Spec+spec = do+    describe "renderRoute" $ do+        it "works on top level" $ do+            case renderRoute (FirstR 1 BlahR) of+                (["first", "1", "blah"], []) ->+                    pure @IO ()+                wrong ->+                    fail $ "Expected renderRoute to work, but got: " <> show wrong
+ test/YesodCoreTest/RenderRouteSpec/TH.hs view
@@ -0,0 +1,32 @@+{-# language TemplateHaskell #-}+{-# language TypeApplications #-}+{-# language OverloadedStrings #-}+{-# language TypeFamilies #-}+{-# language ViewPatterns #-}++-- | Compile-time companion to "YesodCoreTest.RenderRouteSpec": reuses that+-- module's generated @RenderRoute App@ instance and @fail@s the splice unless+-- both @renderRoute@ (full route) and @renderRouteNested@ (from the leaf, given+-- the parent's captured arg) reconstruct the same path. Lives apart from the+-- generating module so the instance is in scope when these top-level splices run.+module YesodCoreTest.RenderRouteSpec.TH where++import Yesod.Routes.Class+import YesodCoreTest.RenderRouteSpec++do+    case renderRoute (FirstR 1 BlahR) of+        (["first", "1", "blah"], []) ->+            pure ()+        wrong ->+            fail $ "Expecte renderRoute to work, but got: " <> show wrong++    pure []++do+    case renderRouteNested 1 BlahR of+        (["first", "1", "blah"], []) ->+            pure []+        wrong ->+            fail $ "Expected renderRouteNested to work, but got: " <> show wrong+
test/YesodCoreTest/Reps.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.Reps     ( specs     , Widget
test/YesodCoreTest/RequestBodySize.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.RequestBodySize     ( specs     , Widget
+ test/YesodCoreTest/RuntimeHarness.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A single WAI round-trip helper shared by the parameterized / nested+-- dispatch runtime specs. Previously each of those modules carried its own+-- near-identical @testRequestIO@, in two disagreeing styles+-- (@shouldBe@-on-@simpleStatus@ vs. @assertStatus@). This is the one shared+-- harness: it takes the action that builds the WAI app plus the request+-- details, and asserts the response status (and body, when given) using+-- 'assertStatus' / 'assertBody' so a mismatch prints the offending response.+module YesodCoreTest.RuntimeHarness+    ( assertRequest+    , assertRequestFor+    , assertGet+    , assertRequestRaw+    ) where++import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import Network.Wai (Application, Request, pathInfo, requestMethod)+import Network.Wai.Test+import Test.Hspec (HasCallStack)+import Yesod.Core (Yesod, YesodDispatch, toWaiApp)+import qualified Network.HTTP.Types as H++-- | Build the WAI app, issue one request at @path@ with @method@, assert the+-- response status, and (when given) assert the body.+assertRequest+    :: HasCallStack+    => IO Application      -- ^ build the WAI app (e.g. @toWaiApp App@)+    -> H.Method            -- ^ request method+    -> Int                 -- ^ expected status code+    -> [Text]              -- ^ request path+    -> Maybe ByteString    -- ^ expected body, if checked+    -> IO ()+assertRequest mkApp method status path mexpected = do+    app <- mkApp+    flip runSession app $ do+        sres <- request defaultRequest+            { pathInfo = path+            , requestMethod = method+            }+        assertStatus status sres+        case mexpected of+            Nothing -> pure ()+            Just expected -> assertBody expected sres++-- | 'assertRequest' specialised to a concrete site: builds the WAI app with+-- 'toWaiApp' for you. This is the shape almost every runtime spec wants, and+-- standardises the argument order (@site → method → status → path → body@) that+-- the per-module @testRequestIO@ wrappers used to spell inconsistently.+assertRequestFor+    :: (HasCallStack, Yesod site, YesodDispatch site)+    => site                -- ^ the site to dispatch against+    -> H.Method            -- ^ request method+    -> Int                 -- ^ expected status code+    -> [Text]              -- ^ request path+    -> Maybe ByteString    -- ^ expected body, if checked+    -> IO ()+assertRequestFor site = assertRequest (toWaiApp site)++-- | 'assertRequestFor' fixed to @GET@ — the common case.+assertGet+    :: (HasCallStack, Yesod site, YesodDispatch site)+    => site -> Int -> [Text] -> Maybe ByteString -> IO ()+assertGet site = assertRequestFor site "GET"++-- | Like 'assertRequest', but issue a fully caller-built 'Request' (e.g. one+-- carrying an @Accept@ header for content negotiation) rather than just a+-- path + method. 'assertStatus'/'assertBody' already print the offending+-- response on a mismatch, so callers don't need their own annotate-on-failure+-- wrapper.+assertRequestRaw+    :: HasCallStack+    => IO Application -> Request -> Int -> Maybe ByteString -> IO ()+assertRequestRaw mkApp req status mexpected = do+    app <- mkApp+    flip runSession app $ do+        sres <- request req+        assertStatus status sres+        case mexpected of+            Nothing -> pure ()+            Just expected -> assertBody expected sres
+ test/YesodCoreTest/SplitSubsite/Data.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Data module for the split-subsite test. Defines a (non-parameterized)+-- subsite with a nested route, and generates its route datatype, render and+-- parse instances. Because the subsite has no type parameters, the+-- nested-discovery machinery (RenderRouteNested / ParseRouteNested for the+-- nested 'NestedR' fragment) is generated here, so that a separately compiled+-- module can supply the matching 'YesodSubDispatchNested' instance.+module YesodCoreTest.SplitSubsite.Data where++import Yesod.Core++data SplitSub = SplitSub++mkYesodSubData "SplitSub" [parseRoutes|+/ SplitHomeR GET+/nested NestedR:+    / NestedHomeR GET+    /detail/#Int NestedDetailR GET+|]
+ test/YesodCoreTest/SplitSubsite/NestedR.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The split-out dispatch module for the subsite's nested 'NestedR'+-- fragment. The handlers for the nested routes live here, alongside the+-- 'YesodSubDispatchNested' instance generated by 'mkNestedSubDispatchInstance'.+--+-- Crucially, this module is compiled /separately/ from the module that+-- defines the subsite's top-level 'YesodSubDispatch' instance. That instance's+-- 'mkYesodSubDispatch' splice sees this 'YesodSubDispatchNested' instance via+-- 'isInstance' and delegates to it — exactly the cross-module splitting that+-- "YesodCoreTest.NestedDispatch.Runtime" demonstrates for top-level sites.+module YesodCoreTest.SplitSubsite.NestedR (NestedR(..)) where++import Yesod.Core+import Yesod.Core.Dispatch+    (mkNestedSubDispatchInstance, defaultOpts, TyArgs(..))+import Data.Text (Text, pack)++import YesodCoreTest.SplitSubsite.Data++getNestedHomeR :: SubHandlerFor SplitSub master Text+getNestedHomeR = pure "nestedHome"++getNestedDetailR :: Int -> SubHandlerFor SplitSub master Text+getNestedDetailR n = pure ("nestedDetail:" <> tshow n)+  where+    tshow = pack . show++$(mkNestedSubDispatchInstance+    defaultOpts+    "NestedR"+    []        -- no instance context+    NoTyArgs  -- no type arguments (non-parameterized subsite)+    return    -- handler unwrapper+    resourcesSplitSub)
+ test/YesodCoreTest/SplitSubsite/Runtime.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | End-to-end test that a subsite's nested routes can be split across+-- modules. The nested dispatch + handlers live in+-- "YesodCoreTest.SplitSubsite.NestedR"; here we only define the host site,+-- the subsite's top-level 'YesodSubDispatch' instance (which delegates to the+-- separately compiled 'YesodSubDispatchNested' instance), and the leaf+-- handler. We never import the nested handlers — proving the split.+module YesodCoreTest.SplitSubsite.Runtime (splitSubsiteSpec) where++import Test.Hspec+import Yesod.Core+import Network.Wai (defaultRequest, pathInfo)+import Network.Wai.Test+import Data.Text (Text)+import qualified Data.ByteString.Lazy.Char8 as L8++import YesodCoreTest.SplitSubsite.Data+-- Bring the split-out YesodSubDispatchNested instance into scope. We import+-- the instance only — none of the nested handlers leak into this module.+import YesodCoreTest.SplitSubsite.NestedR ()++data App = App { getSplit :: SplitSub }++mkYesod "App" [parseRoutes|+/split SplitSubR SplitSub getSplit+|]++instance Yesod App++getSplitHomeR :: SubHandlerFor SplitSub master Text+getSplitHomeR = pure "splitHome"++instance YesodSubDispatch SplitSub master where+  yesodSubDispatch = $(mkYesodSubDispatch resourcesSplitSub)++app :: App+app = App { getSplit = SplitSub }++runner :: Session () -> IO ()+runner f = toWaiApp app >>= runSession f++splitSubsiteSpec :: Spec+splitSubsiteSpec = describe "YesodCoreTest.SplitSubsite.Runtime (split subsite routes)" $ do+    it "dispatches the subsite's own leaf route" $ runner $ do+        res <- request defaultRequest { pathInfo = ["split"] }+        assertStatus 200 res+        assertBody (L8.pack "splitHome") res+    it "delegates the nested home route to the split-out module" $ runner $ do+        res <- request defaultRequest { pathInfo = ["split", "nested"] }+        assertStatus 200 res+        assertBody (L8.pack "nestedHome") res+    it "delegates a nested dynamic route to the split-out module" $ runner $ do+        res <- request defaultRequest { pathInfo = ["split", "nested", "detail", "7"] }+        assertStatus 200 res+        assertBody (L8.pack "nestedDetail:7") res
test/YesodCoreTest/Ssl.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.Ssl ( sslOnlySpec, unsecSpec, sameSiteSpec ) where import qualified YesodCoreTest.StubSslOnly as Ssl import qualified YesodCoreTest.StubLaxSameSite as LaxSameSite@@ -43,7 +48,7 @@     cookiesIn r =       DL.map         (Cookie.parseSetCookie . snd)-        (DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders r)+        (DL.filter (("Set-Cookie" ==) . fst) $ simpleHeaders r)  sslOnlySpec :: Spec sslOnlySpec = describe "A Yesod application with sslOnly on" $ do
test/YesodCoreTest/Streaming.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ module YesodCoreTest.Streaming (specs) where  import Yesod.Core
test/YesodCoreTest/StubLaxSameSite.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.StubLaxSameSite     ( App ( App )     , Widget
test/YesodCoreTest/StubSslOnly.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.StubSslOnly     ( App ( App )     , Widget
test/YesodCoreTest/StubStrictSameSite.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.StubStrictSameSite     ( App ( App )     , Widget
test/YesodCoreTest/StubUnsecured.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ module YesodCoreTest.StubUnsecured     ( App ( App )     , Widget
+ test/YesodCoreTest/SubSub.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module YesodCoreTest.SubSub where++import Test.Hspec++import Yesod.Core+import Network.Wai.Test+import qualified Data.Text as T+import qualified Data.ByteString.Lazy.Char8 as L8++import YesodCoreTest.SubSubData++data App = App { getOuter :: OuterSubSite }++mkYesod "App" [parseRoutes|+/ OuterSubSiteR OuterSubSite getOuter+|]++instance Yesod App++getSubR :: SubHandlerFor InnerSubSite master T.Text+getSubR = return $ T.pack "sub"++instance YesodSubDispatch OuterSubSite master where+  yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite)++instance YesodSubDispatch InnerSubSite master where+  yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite)++app :: App+app = App { getOuter = OuterSubSite { getInner = InnerSubSite }}++runner :: Session () -> IO ()+runner f = toWaiApp app >>= runSession f++case_subSubsite :: IO ()+case_subSubsite = runner $ do+  res <- request defaultRequest+  assertBody (L8.pack "sub") res+  assertStatus 200 res++subSubTest :: Spec+subSubTest = describe "YesodCoreTest.SubSub" $ do+  it "sub_subsite" case_subSubsite
+ test/YesodCoreTest/SubSubData.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module YesodCoreTest.SubSubData where++import Yesod.Core+++data OuterSubSite = OuterSubSite { getInner :: InnerSubSite }++data InnerSubSite = InnerSubSite++mkYesodSubData "InnerSubSite" [parseRoutes|+/ SubR GET+|]++mkYesodSubData "OuterSubSite" [parseRoutes|+/ InnerSubSiteR InnerSubSite getInner+|]
+ test/YesodCoreTest/SubsiteFallthrough/Data.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Subsite route data for the nested-route fallthrough runtime test. Both+-- subsites have a nested parent @WrapR@ containing two sibling sub-parents that+-- share the @\/foo@ prefix: the first (@FooAR@) matches only an empty suffix+-- (its index), the second (@FooBR@) matches @\/bar@. A request for+-- @\/wrap\/foo\/bar@ therefore misses in @FooAR@ and can only reach @FooBR@ by+-- falling through — the behaviour the dispatch modules toggle.+--+-- The route data lives here, apart from the 'mkNestedSubDispatchInstance'+-- splices in "YesodCoreTest.SubsiteFallthrough.Nested", because the+-- generated @resources*@ binding can't feed a splice in the same module (GHC+-- stage restriction) — the same split "YesodCoreTest.SplitSubsite.Runtime" uses.+module YesodCoreTest.SubsiteFallthrough.Data where++import Yesod.Core++data FallOnSub = FallOnSub++mkYesodSubData "FallOnSub" [parseRoutes|+/wrap OnWrapR:+    /foo OnFooAR:+        / OnFooAIndexR GET+    /foo OnFooBR:+        /bar OnFooBBarR GET+|]++data FallOffSub = FallOffSub++mkYesodSubData "FallOffSub" [parseRoutes|+/wrap OffWrapR:+    /foo OffFooAR:+        / OffFooAIndexR GET+    /foo OffFooBR:+        /bar OffFooBBarR GET+|]
+ test/YesodCoreTest/SubsiteFallthrough/Nested.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The split-out dispatch module for the fallthrough subsites' nested+-- @WrapR@ fragments. The nested handlers live here, alongside the+-- 'YesodSubDispatchNested' instances generated by 'mkNestedSubDispatchInstance'+-- — @FallOnSub@ with fallthrough enabled, @FallOffSub@ at the default.+--+-- Compiled separately from "YesodCoreTest.SubsiteFallthrough.Runtime" so the host+-- site's 'mkYesodSubDispatch' splice sees these instances via 'isInstance' and+-- delegates @WrapR@ to them; the delegated 'YesodSubDispatchNested' is what+-- routes through 'genNestedDispatchClauses' and so honours the fallthrough+-- flag baked in here.+module YesodCoreTest.SubsiteFallthrough.Nested () where++import Yesod.Core+import Yesod.Core.Dispatch+    (mkNestedSubDispatchInstance, TyArgs(..))+import Data.Text (Text)++import YesodCoreTest.SubsiteFallthrough.Data++-- Fallthrough ENABLED subsite ----------------------------------------------++getOnFooAIndexR :: SubHandlerFor FallOnSub master Text+getOnFooAIndexR = pure "onFooAIndex"++getOnFooBBarR :: SubHandlerFor FallOnSub master Text+getOnFooBBarR = pure "onFooBBar"++$(mkNestedSubDispatchInstance+    (setNestedRouteFallthrough True defaultOpts)+    "OnWrapR"+    []+    NoTyArgs+    return+    resourcesFallOnSub)++-- Fallthrough DISABLED subsite (default opts) ------------------------------++getOffFooAIndexR :: SubHandlerFor FallOffSub master Text+getOffFooAIndexR = pure "offFooAIndex"++getOffFooBBarR :: SubHandlerFor FallOffSub master Text+getOffFooBBarR = pure "offFooBBar"++$(mkNestedSubDispatchInstance+    defaultOpts+    "OffWrapR"+    []+    NoTyArgs+    return+    resourcesFallOffSub)
+ test/YesodCoreTest/SubsiteFallthrough/Runtime.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime (WAI) coverage for subsite nested-route fallthrough. Every other+-- 'setNestedRouteFallthrough' fixture is a top-level site; this mounts two+-- subsites — one with fallthrough enabled, one without — and proves that a+-- request which misses inside a nested parent reaches the sibling route only+-- when the subsite was generated with fallthrough on. See+-- "YesodCoreTest.SubsiteFallthrough.Data" for the subsite definitions.+module YesodCoreTest.SubsiteFallthrough.Runtime (specs) where++import Test.Hspec+import Yesod.Core++import YesodCoreTest.SubsiteFallthrough.Data+-- Bring the split-out YesodSubDispatchNested instances into scope (instances+-- only) so the host site's mkYesodSubDispatch delegates WrapR to them.+import YesodCoreTest.SubsiteFallthrough.Nested ()+import YesodCoreTest.RuntimeHarness (assertGet)++data FallApp = FallApp++getOnSub :: FallApp -> FallOnSub+getOnSub _ = FallOnSub++getOffSub :: FallApp -> FallOffSub+getOffSub _ = FallOffSub++mkYesod "FallApp" [parseRoutes|+/on  OnSubR  FallOnSub  getOnSub+/off OffSubR FallOffSub getOffSub+|]++instance Yesod FallApp++-- The host site delegates each subsite's nested @WrapR@ to the+-- 'YesodSubDispatchNested' instance imported from+-- "YesodCoreTest.SubsiteFallthrough.Data".+instance YesodSubDispatch FallOnSub master where+  yesodSubDispatch = $(mkYesodSubDispatch resourcesFallOnSub)++instance YesodSubDispatch FallOffSub master where+  yesodSubDispatch = $(mkYesodSubDispatch resourcesFallOffSub)++specs :: Spec+specs = describe "YesodCoreTest.SubsiteFallthrough.Runtime (subsite nested-route fallthrough)" $ do+    describe "fallthrough enabled" $ do+        it "still reaches the shadowing nested index route" $+            assertGet FallApp 200 ["on", "wrap", "foo"] (Just "onFooAIndex")+        it "falls through a nested miss to the sibling route" $+            assertGet FallApp 200 ["on", "wrap", "foo", "bar"] (Just "onFooBBar")++    describe "fallthrough disabled (default)" $ do+        it "still reaches the shadowing nested index route" $+            assertGet FallApp 200 ["off", "wrap", "foo"] (Just "offFooAIndex")+        it "404s after a nested miss instead of falling through to the sibling" $+            assertGet FallApp 404 ["off", "wrap", "foo", "bar"] Nothing
+ test/YesodCoreTest/SubsiteOptsFallthrough/Data.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Subsite route data for the 'mkYesodSubDispatchInstanceOpts' fallthrough+-- runtime test. Unlike "YesodCoreTest.SubsiteFallthrough.Data" (whose sibling+-- parents live one level down inside @WrapR@), these subsites place two+-- same-prefix parents at the subsite's *own top level* — the exact seam that+-- the @yesodSubDispatch@ body's inline parent clauses govern. @FirstFooR@+-- matches only an empty suffix (its index); @SecondFooR@ matches @\/bar@. A+-- request for @\/foo\/bar@ misses inside @FirstFooR@ and can only reach+-- @SecondFooR@ by falling through — the behaviour that+-- 'mkYesodSubDispatchInstanceOpts' must now thread into the body via+-- 'setNestedRouteFallthrough'.+--+-- The route data lives apart from the dispatch splice (which goes in the test+-- module) because the generated @resources*@ binding can't feed a splice in+-- the same module (GHC stage restriction).+module YesodCoreTest.SubsiteOptsFallthrough.Data where++import Yesod.Core++data OptsOnSub = OptsOnSub++mkYesodSubData "OptsOnSub" [parseRoutes|+/foo OnFirstFooR:+    / OnFooIndexR GET+/foo OnSecondFooR:+    /bar OnFooBarR GET+|]++data OptsOffSub = OptsOffSub++mkYesodSubData "OptsOffSub" [parseRoutes|+/foo OffFirstFooR:+    / OffFooIndexR GET+/foo OffSecondFooR:+    /bar OffFooBarR GET+|]
+ test/YesodCoreTest/SubsiteOptsFallthrough/Runtime.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Runtime (WAI) coverage for 'mkYesodSubDispatchInstanceOpts' with+-- 'setNestedRouteFallthrough'. The headline use case of that entry point —+-- a subsite whose own top-level parent clauses fall through to a later sibling+-- on an inner miss — was previously a no-op: the generated @yesodSubDispatch@+-- body came from the opts-less 'mkYesodSubDispatch', which hardcoded+-- @mdsNestedRouteFallthrough = False@. This pins the fix.+--+-- Two subsites are mounted: 'OptsOnSub' generated with fallthrough on,+-- 'OptsOffSub' at the default. Both have two same-prefix top-level parents+-- (@\/foo FirstFooR@ then @\/foo SecondFooR@); @\/foo\/bar@ reaches the+-- @SecondFooR@ sibling only when the body honours the flag. See+-- "YesodCoreTest.SubsiteOptsFallthrough.Data" for the route data.+module YesodCoreTest.SubsiteOptsFallthrough.Runtime (specs) where++import Data.Text (Text)+import Test.Hspec+import Yesod.Core+import Yesod.Core.Dispatch (mkYesodSubDispatchInstanceOpts)++import YesodCoreTest.SubsiteOptsFallthrough.Data+import YesodCoreTest.RuntimeHarness (assertGet)++-- Handlers for the fallthrough-ENABLED subsite.+getOnFooIndexR :: SubHandlerFor OptsOnSub master Text+getOnFooIndexR = pure "onFooIndex"++getOnFooBarR :: SubHandlerFor OptsOnSub master Text+getOnFooBarR = pure "onFooBar"++-- Handlers for the fallthrough-DISABLED subsite.+getOffFooIndexR :: SubHandlerFor OptsOffSub master Text+getOffFooIndexR = pure "offFooIndex"++getOffFooBarR :: SubHandlerFor OptsOffSub master Text+getOffFooBarR = pure "offFooBar"++-- The API under test: the @yesodSubDispatch@ body must thread the fallthrough+-- flag from these opts so the subsite's own top-level @FirstFooR@/@SecondFooR@+-- siblings fall through. Placed before 'mkYesod' so the host dispatch sees the+-- generated subsite instances.+mkYesodSubDispatchInstanceOpts+    (setNestedRouteFallthrough True defaultOpts)+    "OptsOnSub"+    resourcesOptsOnSub++mkYesodSubDispatchInstanceOpts+    defaultOpts+    "OptsOffSub"+    resourcesOptsOffSub++data OptsFallApp = OptsFallApp++getOnSub :: OptsFallApp -> OptsOnSub+getOnSub _ = OptsOnSub++getOffSub :: OptsFallApp -> OptsOffSub+getOffSub _ = OptsOffSub++mkYesod "OptsFallApp" [parseRoutes|+/on  OnSubR  OptsOnSub  getOnSub+/off OffSubR OptsOffSub getOffSub+|]++instance Yesod OptsFallApp++specs :: Spec+specs = describe "YesodCoreTest.SubsiteOptsFallthrough.Runtime (mkYesodSubDispatchInstanceOpts fallthrough)" $ do+    describe "fallthrough enabled (setNestedRouteFallthrough True)" $ do+        it "still reaches the shadowing top-level index route" $+            assertGet OptsFallApp 200 ["on", "foo"] (Just "onFooIndex")+        it "falls through a top-level parent miss to the sibling route" $+            assertGet OptsFallApp 200 ["on", "foo", "bar"] (Just "onFooBar")++    describe "fallthrough disabled (default)" $ do+        it "still reaches the shadowing top-level index route" $+            assertGet OptsFallApp 200 ["off", "foo"] (Just "offFooIndex")+        it "404s after a top-level parent miss instead of falling through" $+            assertGet OptsFallApp 404 ["off", "foo", "bar"] Nothing
test/YesodCoreTest/WaiSubsite.hs view
@@ -1,4 +1,11 @@-{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.WaiSubsite     ( specs     , Widget
test/YesodCoreTest/Widget.hs view
@@ -1,6 +1,11 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+ module YesodCoreTest.Widget     ( widgetTest     , resourcesY@@ -98,7 +103,7 @@     assertBody "<!DOCTYPE html>\n<html><head><title></title><script>toHead</script><toHead></toHead>\n<style>toWidget{bar:baz}toHead{bar:baz}</style></head><body><script>toBody</script><p>toWidget</p>\n<p>toBody</p>\n<script>toWidget</script></body></html>" res  runner :: Session () -> IO ()-runner f = toWaiApp Y >>= runSession f+runner f = toWaiAppPlain Y >>= runSession f  case_addJuliusBody :: IO () case_addJuliusBody = runner $ do
+ test/YesodCoreTest/ZeroPieceShadow/FallApp.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | The same zero-piece-parent shape as "YesodCoreTest.ZeroPieceShadow.ShadowApp",+-- but built with @'setNestedRouteFallthrough' True@. With fallthrough enabled+-- the @WildP@ parent no longer swallows non-matching paths, so the sibling+-- @\/sibling@ becomes reachable. Pinned by "YesodCoreTest.ZeroPieceShadowRuntime".+module YesodCoreTest.ZeroPieceShadow.FallApp+    ( FallApp (..)+    ) where++import Yesod.Core++data FallApp = FallApp++mkYesodOpts (setNestedRouteFallthrough True defaultOpts) "FallApp" [parseRoutes|+/ FallParentR:+    /child FallChildR GET+/sibling FallSiblingR GET+|]++instance Yesod FallApp where+    messageLoggerSource = mempty++getFallChildR :: HandlerFor FallApp String+getFallChildR = pure "FallChildR"++getFallSiblingR :: HandlerFor FallApp String+getFallSiblingR = pure "FallSiblingR"
+ test/YesodCoreTest/ZeroPieceShadow/ShadowApp.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | A zero-piece nested parent (pattern @\/@) followed by a sibling, built with+-- the default @fallthrough = False@. The parent's match pattern is @WildP@+-- (unconditional), so @\/sibling@ is shadowed: it is swallowed by the parent+-- and 404s. See "YesodCoreTest.ZeroPieceShadow.FallApp" for the fallthrough+-- counterpart. Pinned by "YesodCoreTest.ZeroPieceShadowRuntime".+module YesodCoreTest.ZeroPieceShadow.ShadowApp+    ( ShadowApp (..)+    ) where++import Yesod.Core++data ShadowApp = ShadowApp++mkYesodOpts defaultOpts "ShadowApp" [parseRoutes|+/ ShadowParentR:+    /child ShadowChildR GET+/sibling SiblingR GET+|]++instance Yesod ShadowApp where+    messageLoggerSource = mempty++getShadowChildR :: HandlerFor ShadowApp String+getShadowChildR = pure "ShadowChildR"++getSiblingR :: HandlerFor ShadowApp String+getSiblingR = pure "SiblingR"
+ test/YesodCoreTest/ZeroPieceShadowRuntime.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Regression coverage for the documented edge case: a nested parent route+-- with /no/ leading path piece (pattern @\/@) compiles to an unconditional+-- first match ('mkPathPat' @EndWild []@ = @WildP@), so any sibling route+-- declared after it is unreachable under the default+-- @'setNestedRouteFallthrough' False@. Enabling fallthrough lets a non-matching+-- subtree fall through to the siblings.+--+-- This is unchanged behaviour from previous releases (the leaf-level overlap+-- check never flagged it, since the parent contributes zero pieces and the+-- flattened leaf paths @\/child@ vs @\/sibling@ do not overlap). The+-- @EndWild@/@PathTail@ abstraction made the shadow silent, so it is pinned here.+module YesodCoreTest.ZeroPieceShadowRuntime+    ( specs+    ) where++import Test.Hspec+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)+import YesodCoreTest.ZeroPieceShadow.ShadowApp (ShadowApp (..))+import YesodCoreTest.ZeroPieceShadow.FallApp (FallApp (..))+import YesodCoreTest.RuntimeHarness (assertGet)++shadowReq :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+shadowReq = assertGet ShadowApp++fallReq :: HasCallStack => Int -> [Text] -> Maybe ByteString -> IO ()+fallReq = assertGet FallApp++specs :: Spec+specs = describe "zero-piece nested parent shadowing siblings" $ do+    describe "default fallthrough = False (the parent's WildP shadows the sibling)" $ do+        it "still dispatches the parent's own child (/child)" $+            shadowReq 200 ["child"] (Just "ShadowChildR")+        it "404s the shadowed sibling (/sibling), which the WildP parent swallows" $+            shadowReq 404 ["sibling"] Nothing++    describe "setNestedRouteFallthrough True (the sibling becomes reachable)" $ do+        it "still dispatches the parent's own child (/child)" $+            fallReq 200 ["child"] (Just "FallChildR")+        it "falls through the WildP parent to the sibling (/sibling)" $+            fallReq 200 ["sibling"] (Just "FallSiblingR")
− test/fixtures/routes_with_line_continuations 
@@ -1,11 +0,0 @@--- This fixture to test line continuations is in a separate file--- because when I put it in an in-line quasi-quotation, the compiler--- performed the line continuations processing itself.--/foo1 \-    Foo1-/foo2 Foo2-/foo3 \-    Foo3 \-    GET POST \-    !foo
+ test/fixtures/routes_with_line_continuations.yesodroutes view
@@ -0,0 +1,11 @@+-- This fixture to test line continuations is in a separate file+-- because when I put it in an in-line quasi-quotation, the compiler+-- performed the line continuations processing itself.++/foo1 \+    Foo1+/foo2 Foo2+/foo3 \+    Foo3 \+    GET POST \+    !foo
yesod-core.cabal view
@@ -1,5 +1,5 @@ name:            yesod-core-version:         1.6.14+version:         1.7.0.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -8,7 +8,7 @@ description:     API docs and the README are available at <http://www.stackage.org/package/yesod-core> category:        Web, Yesod stability:       Stable-cabal-version:   >= 1.8+cabal-version:   >= 1.10 build-type:      Simple homepage:        http://www.yesodweb.com/ extra-source-files:@@ -17,15 +17,18 @@   test/YesodCoreTest/JsLoaderSites/Bottom.hs   test/en.msg   test/test.hs-  test/fixtures/routes_with_line_continuations+  test/fixtures/routes_with_line_continuations.yesodroutes   ChangeLog.md   README.md+  docs/split-route-compilation.md  library+    default-language: Haskell2010     hs-source-dirs: src -    build-depends:   base                  >= 4.9      && < 5+    build-depends:   base                  >= 4.11     && < 5                    , aeson                 >= 1.0+                   , attoparsec-aeson      >= 2.1                    , auto-update                    , blaze-html            >= 0.5                    , blaze-markup          >= 0.7.1@@ -36,8 +39,11 @@                    , conduit               >= 1.3                    , conduit-extra                    , containers            >= 0.2-                   , cookie                >= 0.4.3    && < 0.5+                   , cookie                >= 0.4.3    && < 0.6+                   , data-default                    , deepseq               >= 1.3+                   , encoding+                   , entropy                    , fast-logger           >= 2.2                    , http-types            >= 0.7                    , memory@@ -46,18 +52,19 @@                    , parsec                >= 2        && < 3.2                    , path-pieces           >= 0.1.2    && < 0.3                    , primitive             >= 0.6-                   , random                >= 1.0.0.2  && < 1.2+                   , random                >= 1.0.0.2  && < 1.4                    , resourcet             >= 1.2-                   , rio                    , shakespeare           >= 2.0-                   , template-haskell      >= 2.11+                   , template-haskell      >= 2.13                    , text                  >= 0.7+                   , th-compat             >= 0.1+                   , th-lift-instances     >= 0.1                    , time                  >= 1.5                    , transformers          >= 0.4                    , unix-compat                    , unliftio                    , unordered-containers  >= 0.2-                   , vector                >= 0.9      && < 0.13+                   , vector                >= 0.9      && < 0.14                    , wai                   >= 3.2                    , wai-extra             >= 3.0.7                    , wai-logger            >= 0.2@@ -74,6 +81,7 @@                      Yesod.Core.Types                      Yesod.Core.Unsafe                      Yesod.Routes.TH.Types+                     Yesod.Core.Class.Dispatch.ToParentRoute     other-modules:   Yesod.Core.Internal.Session                      Yesod.Core.Internal.Request                      Yesod.Core.Class.Handler@@ -86,6 +94,10 @@                      Yesod.Core.Class.Dispatch                      Yesod.Core.Class.Breadcrumbs                      Yesod.Core.TypeCache+                     Yesod.Core.Types.Content+                     Yesod.Core.Types.ErrorResponse+                     Yesod.Core.Types.HandlerContents+                     Yesod.Core.Types.TypedContent                      Paths_yesod_core                       Yesod.Routes.TH@@ -96,21 +108,26 @@                      Yesod.Routes.TH.RenderRoute                      Yesod.Routes.TH.ParseRoute                      Yesod.Routes.TH.RouteAttrs+                     Yesod.Routes.TH.Internal      ghc-options:     -Wall-    -- Following line added due to: https://github.com/yesodweb/yesod/issues/545-    -- This looks like a GHC bug-    extensions:      MultiParamTypeClasses      -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443-    extensions:      TemplateHaskell+    other-extensions:      TemplateHaskell  test-suite test-routes+    default-language: Haskell2010     type: exitcode-stdio-1.0     main-is: RouteSpec.hs     hs-source-dirs: test, src      other-modules: Hierarchy+                   Hierarchy.Admin+                   Hierarchy.ResourceTree+                   Hierarchy.Nest2.NestInner+                   Hierarchy.Nest2+                   Hierarchy.Nest3+                   Hierarchy.Nest                    Yesod.Routes.Class                    Yesod.Routes.Overlap                    Yesod.Routes.Parse@@ -120,34 +137,99 @@                    Yesod.Routes.TH.RenderRoute                    Yesod.Routes.TH.RouteAttrs                    Yesod.Routes.TH.Types+                   Yesod.Routes.TH.Internal+                   Route.FallthroughSpec+                   YesodCoreTest.RuntimeHarness+                   Route.RenderRouteSpec+                   Route.RouteAttrSpec+                   Route.DiscoveryModeSpec+                   Route.SubDispatchAritySpec+                   Route.DeepAritySpec+                   Route.DeepArityTypes+                   Route.InstanceProbeSpec+                   Route.InstanceProbeTypes+                   Route.InlineParseClausesSpec+                   Route.NestedParseClausesSpec+                   Route.PureQ+                   Route.FocusLeafConsSpec+                   Route.MissingFocusTargetSpec+                   Route.MissingFocusTargetTypes+                   YesodCoreTest.RenderRouteSpec+                   YesodCoreTest.RenderRouteSpec.TH      -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443-    extensions:      TemplateHaskell+    other-extensions:      TemplateHaskell -    build-depends: base-                 , hspec-                 , containers+    build-depends: base < 5+                 , HUnit+                 , aeson+                 , attoparsec-aeson+                 , auto-update+                 , blaze-html+                 , blaze-markup                  , bytestring+                 , hspec-expectations+                 , case-insensitive+                 , cereal+                 , clientsession+                 , conduit+                 , conduit-extra+                 , containers+                 , cookie+                 , data-default+                 , deepseq+                 , encoding+                 , entropy+                 , fast-logger+                 , hspec+                 , http-types+                 , memory+                 , monad-logger+                 , mtl+                 , parsec+                 , path-pieces+                 , primitive+                 , random+                 , resourcet+                 , shakespeare                  , template-haskell                  , text-                 , random-                 , path-pieces-                 , HUnit+                 , th-abstraction+                 , th-compat+                 , th-lift-instances+                 , time+                 , transformers+                 , unix-compat+                 , unliftio+                 , unordered-containers+                 , vector+                 , wai+                 , wai-extra+                 , wai-logger+                 , warp+                 , word8  test-suite tests+    default-language: Haskell2010     type: exitcode-stdio-1.0     main-is: test.hs     hs-source-dirs: test      other-modules: YesodCoreTest                    YesodCoreTest.Auth+                   YesodCoreTest.Breadcrumb                    YesodCoreTest.Cache                    YesodCoreTest.CleanPath+                   YesodCoreTest.Content                    YesodCoreTest.Header                    YesodCoreTest.Csrf                    YesodCoreTest.ErrorHandling+                   YesodCoreTest.ErrorHandling.CustomApp                    YesodCoreTest.Exceptions+                   YesodCoreTest.FallthroughDispatch.Runtime+                   YesodCoreTest.FallthroughDispatch.Resources                    YesodCoreTest.InternalRequest+                   YesodCoreTest.JsAttributes                    YesodCoreTest.JsLoader                    YesodCoreTest.JsLoaderSites.Bottom                    YesodCoreTest.Json@@ -155,8 +237,21 @@                    YesodCoreTest.LiteApp                    YesodCoreTest.Media                    YesodCoreTest.MediaData+                   YesodCoreTest.Meta+                   YesodCoreTest.NestedDispatch.Runtime+                   YesodCoreTest.NestedDispatch.NestR+                   YesodCoreTest.NestedDispatch.InnerR+                   YesodCoreTest.NestedDispatch.ParentR+                   YesodCoreTest.NestedDispatch.Parent0R+                   YesodCoreTest.NestedDispatch.Parent0R.Child0R+                   YesodCoreTest.NestedDispatch.Resources                    YesodCoreTest.NoOverloadedStrings                    YesodCoreTest.NoOverloadedStringsSub+                   YesodCoreTest.ParameterizedSite+                   YesodCoreTest.ParameterizedSite.Compat+                   YesodCoreTest.ParameterizedSite.PolyAny+                   YesodCoreTest.ParameterizedSite.PolyShow+                   YesodCoreTest.ParameterizedSite.SubRoute                    YesodCoreTest.RawResponse                    YesodCoreTest.Redirect                    YesodCoreTest.Reps@@ -167,6 +262,44 @@                    YesodCoreTest.StubSslOnly                    YesodCoreTest.StubStrictSameSite                    YesodCoreTest.StubUnsecured+                   YesodCoreTest.SubSub+                   YesodCoreTest.SubSubData+                   YesodCoreTest.SplitSubsite.Runtime+                   YesodCoreTest.SplitSubsite.Data+                   YesodCoreTest.SplitSubsite.NestedR+                   YesodCoreTest.ParameterizedSubData+                   YesodCoreTest.ParamSubsite.Data+                   YesodCoreTest.ParameterizedSubDispatch+                   YesodCoreTest.ParameterizedSubDispatch.Data+                   YesodCoreTest.ParameterizedSubDispatchRuntime+                   YesodCoreTest.ParameterizedSubDispatchRuntime.Data+                   YesodCoreTest.ParamSubsite.InstanceRuntime+                   YesodCoreTest.RuntimeHarness+                   YesodCoreTest.ParamSubsite.SplitNested+                   YesodCoreTest.ParamSubsite.SplitRuntime+                   YesodCoreTest.ParamDefaultSplit.Data+                   YesodCoreTest.ParamDefaultSplit.Runtime+                   YesodCoreTest.ParamTopLevelRuntime+                   YesodCoreTest.ParamFocusSplit.Runtime+                   YesodCoreTest.ParamFocusSplit.Resources+                   YesodCoreTest.ParamFocusSplit.SubR+                   YesodCoreTest.ParamNoExplicitArgs+                   YesodCoreTest.ParamFallthroughRuntime+                   YesodCoreTest.ParamNoFallthroughRuntime+                   YesodCoreTest.ParamNestedNoFallthroughRuntime+                   YesodCoreTest.FallthroughMatrix.Resources+                   YesodCoreTest.FallthroughMatrix.FirstFoo+                   YesodCoreTest.FallthroughMatrix.Runtime+                   YesodCoreTest.MultiPieceNestedRuntime+                   YesodCoreTest.ZeroPieceShadowRuntime+                   YesodCoreTest.ZeroPieceShadow.ShadowApp+                   YesodCoreTest.ZeroPieceShadow.FallApp+                   YesodCoreTest.BangSeparatorRuntime+                   YesodCoreTest.SubsiteFallthrough.Runtime+                   YesodCoreTest.SubsiteFallthrough.Data+                   YesodCoreTest.SubsiteFallthrough.Nested+                   YesodCoreTest.SubsiteOptsFallthrough.Runtime+                   YesodCoreTest.SubsiteOptsFallthrough.Data                    YesodCoreTest.WaiSubsite                    YesodCoreTest.Widget                    YesodCoreTest.YesodTest@@ -174,14 +307,16 @@     cpp-options:   -DTEST     if os(windows)         cpp-options: -DWINDOWS-    build-depends:  base+    build-depends:  base >= 4.11 && < 5                   , async                   , bytestring                   , clientsession                   , conduit                   , conduit-extra                   , containers-                  , cookie >= 0.4.1    && < 0.5+                  , cookie >= 0.4.1    && < 0.6+                  , data-default+                  , encoding                   , hspec >= 1.3                   , hspec-expectations                   , http-types@@ -190,20 +325,52 @@                   , resourcet                   , shakespeare                   , streaming-commons+                  , template-haskell                   , text                   , transformers                   , unliftio+                  , unordered-containers+                  , path-pieces+                  , mtl+                  , time+                  , cereal+                  , monad-logger+                  , deepseq+                  , blaze-html+                  , aeson+                  , primitive+                  , case-insensitive+                  , wai-logger+                  , memory+                  , unix-compat+                  , auto-update+                  , vector+                  , word8+                  , blaze-markup+                  , fast-logger+                  , parsec                   , wai >= 3.0+                  , entropy+                  , attoparsec-aeson                   , wai-extra                   , warp+                  , th-lift-instances                   , yesod-core+    -- NB: this behavioral suite depends on the *packaged* yesod-core library+    -- (no `src` on hs-source-dirs), so it compiles against the real+    -- exposed/hidden module boundary. That is what catches API-exposure+    -- regressions (a module that downstream consumers cannot import). The+    -- pure-codegen suite `test-routes` keeps `src` on hs-source-dirs because it+    -- legitimately needs internal modules (e.g. Yesod.Routes.TH.RenderRoute,+    -- Yesod.Routes.Class) for compile-time codegen assertions.     ghc-options:     -Wall -threaded-    extensions: TemplateHaskell+    other-extensions: TemplateHaskell  benchmark widgets+    default-language: Haskell2010     type: exitcode-stdio-1.0     hs-source-dirs: bench-    build-depends:  base+    build-depends:  base < 5                   , blaze-html                   , bytestring                   , gauge