yesod-core 1.6.29.1 → 1.7.0.0

raw patch · 93 files changed

+8958/−1033 lines, 93 filesdep +th-compatdep +th-lift-instancesdep ~aesondep ~attoparsec-aesondep ~blaze-htmlPVP ok

version bump matches the API change (PVP)

Dependencies added: th-compat, th-lift-instances

Dependency ranges changed: aeson, attoparsec-aeson, blaze-html, blaze-markup, case-insensitive, cereal, clientsession, conduit, cookie, deepseq, fast-logger, http-types, monad-logger, parsec, path-pieces, primitive, resourcet, shakespeare, template-haskell, time, transformers, unordered-containers, vector, wai, wai-extra, wai-logger, warp

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• docs/split-route-compilation.md +256/−0
• src/Yesod/Core.hs +18/−0
• src/Yesod/Core/Class/Dispatch.hs +196/−4
• src/Yesod/Core/Class/Dispatch/ToParentRoute.hs +18/−0
• src/Yesod/Core/Dispatch.hs +73/−38
• src/Yesod/Core/Handler.hs +14/−0
• src/Yesod/Core/Internal/TH.hs +290/−166
• src/Yesod/Core/Types/Content.hs +1/−1
• src/Yesod/Routes/Class.hs +96/−0
• src/Yesod/Routes/Overlap.hs +10/−2
• src/Yesod/Routes/Parse.hs +106/−80
• src/Yesod/Routes/TH.hs +31/−2
• src/Yesod/Routes/TH/Dispatch.hs +1054/−213
• src/Yesod/Routes/TH/Internal.hs +412/−0
• src/Yesod/Routes/TH/ParseRoute.hs +320/−34
• src/Yesod/Routes/TH/RenderRoute.hs +792/−129
• src/Yesod/Routes/TH/RouteAttrs.hs +90/−20
• src/Yesod/Routes/TH/Types.hs +104/−19
• test/Hierarchy.hs +145/−159
• test/Hierarchy/Admin.hs +29/−0
• test/Hierarchy/Nest.hs +29/−0
• test/Hierarchy/Nest2.hs +28/−0
• test/Hierarchy/Nest2/NestInner.hs +23/−0
• test/Hierarchy/Nest3.hs +16/−0
• test/Hierarchy/ResourceTree.hs +54/−0
• test/Route/DeepAritySpec.hs +61/−0
• test/Route/DeepArityTypes.hs +15/−0
• test/Route/DiscoveryModeSpec.hs +49/−0
• test/Route/FallthroughSpec.hs +108/−0
• test/Route/FocusLeafConsSpec.hs +73/−0
• test/Route/InlineParseClausesSpec.hs +213/−0
• test/Route/InstanceProbeSpec.hs +151/−0
• test/Route/InstanceProbeTypes.hs +116/−0
• test/Route/MissingFocusTargetSpec.hs +83/−0
• test/Route/MissingFocusTargetTypes.hs +29/−0
• test/Route/NestedParseClausesSpec.hs +61/−0
• test/Route/PureQ.hs +34/−0
• test/Route/RenderRouteSpec.hs +47/−0
• test/Route/RouteAttrSpec.hs +54/−0
• test/Route/SubDispatchAritySpec.hs +78/−0
• test/RouteSpec.hs +68/−160
• test/YesodCoreTest.hs +43/−0
• test/YesodCoreTest/BangSeparatorRuntime.hs +51/−0
• test/YesodCoreTest/FallthroughDispatch/Resources.hs +36/−0
• test/YesodCoreTest/FallthroughDispatch/Runtime.hs +74/−0
• test/YesodCoreTest/FallthroughMatrix/FirstFoo.hs +32/−0
• test/YesodCoreTest/FallthroughMatrix/Resources.hs +40/−0
• test/YesodCoreTest/FallthroughMatrix/Runtime.hs +100/−0
• test/YesodCoreTest/MultiPieceNestedRuntime.hs +57/−0
• test/YesodCoreTest/NestedDispatch/InnerR.hs +29/−0
• test/YesodCoreTest/NestedDispatch/NestR.hs +27/−0
• test/YesodCoreTest/NestedDispatch/Parent0R.hs +36/−0
• test/YesodCoreTest/NestedDispatch/Parent0R/Child0R.hs +31/−0
• test/YesodCoreTest/NestedDispatch/ParentR.hs +30/−0
• test/YesodCoreTest/NestedDispatch/Resources.hs +59/−0
• test/YesodCoreTest/NestedDispatch/Runtime.hs +599/−0
• test/YesodCoreTest/ParamDefaultSplit/Data.hs +28/−0
• test/YesodCoreTest/ParamDefaultSplit/Runtime.hs +88/−0
• test/YesodCoreTest/ParamFallthroughRuntime.hs +85/−0
• test/YesodCoreTest/ParamFocusSplit/Resources.hs +24/−0
• test/YesodCoreTest/ParamFocusSplit/Runtime.hs +92/−0
• test/YesodCoreTest/ParamFocusSplit/SubR.hs +35/−0
• test/YesodCoreTest/ParamNestedNoFallthroughRuntime.hs +75/−0
• test/YesodCoreTest/ParamNoExplicitArgs.hs +86/−0
• test/YesodCoreTest/ParamNoFallthroughRuntime.hs +77/−0
• test/YesodCoreTest/ParamSubsite/Data.hs +45/−0
• test/YesodCoreTest/ParamSubsite/InstanceRuntime.hs +118/−0
• test/YesodCoreTest/ParamSubsite/SplitNested.hs +65/−0
• test/YesodCoreTest/ParamSubsite/SplitRuntime.hs +113/−0
• test/YesodCoreTest/ParamTopLevelRuntime.hs +96/−0
• test/YesodCoreTest/ParameterizedSite/SubRoute.hs +12/−0
• test/YesodCoreTest/ParameterizedSubData.hs +50/−0
• test/YesodCoreTest/ParameterizedSubDispatch.hs +67/−0
• test/YesodCoreTest/ParameterizedSubDispatch/Data.hs +27/−0
• test/YesodCoreTest/ParameterizedSubDispatchRuntime.hs +181/−0
• test/YesodCoreTest/ParameterizedSubDispatchRuntime/Data.hs +44/−0
• test/YesodCoreTest/RenderRouteSpec.hs +51/−0
• test/YesodCoreTest/RenderRouteSpec/TH.hs +32/−0
• test/YesodCoreTest/RuntimeHarness.hs +83/−0
• test/YesodCoreTest/SplitSubsite/Data.hs +24/−0
• test/YesodCoreTest/SplitSubsite/NestedR.hs +42/−0
• test/YesodCoreTest/SplitSubsite/Runtime.hs +62/−0
• test/YesodCoreTest/SubsiteFallthrough/Data.hs +40/−0
• test/YesodCoreTest/SubsiteFallthrough/Nested.hs +59/−0
• test/YesodCoreTest/SubsiteFallthrough/Runtime.hs +63/−0
• test/YesodCoreTest/SubsiteOptsFallthrough/Data.hs +41/−0
• test/YesodCoreTest/SubsiteOptsFallthrough/Runtime.hs +87/−0
• test/YesodCoreTest/WaiSubsite.hs +1/−0
• test/YesodCoreTest/ZeroPieceShadow/FallApp.hs +35/−0
• test/YesodCoreTest/ZeroPieceShadow/ShadowApp.hs +36/−0
• test/YesodCoreTest/ZeroPieceShadowRuntime.hs +43/−0
• yesod-core.cabal +150/−6

@@ -1,5 +1,17 @@ # 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)

@@ -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.

@@ -8,10 +8,23 @@     ( -- * 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@@ -19,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@@ -141,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

@@ -1,26 +1,171 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}+{-# 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@@ -51,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)

@@ -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

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -22,6 +24,21 @@     , 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@@ -29,7 +46,10 @@     , setShowDerived     , setReadDerived     , setCreateResources+    , setFocusOnNestedRoute+    , unsetFocusOnNestedRoute     , setParameterizedSubroute+    , setNestedRouteFallthrough       -- *** Helpers     , defaultGen     , getGetMaxExpires@@ -40,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 (..)@@ -54,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 @@ -64,23 +92,21 @@ 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) #if !MIN_VERSION_wai_extra(3,1,14) import Data.Default (def) #endif-import Network.HTTP.Types (status301, status307) 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 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@@ -105,17 +131,52 @@ -- 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'. --@@ -138,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:

@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -263,6 +264,8 @@ 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 :: Type -> Type) = HandlerFor site {-# DEPRECATED HandlerT "Use HandlerFor directly" #-}@@ -1031,6 +1034,17 @@     toTextUrl url = do         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

@@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}  module Yesod.Core.Internal.TH@@ -33,9 +34,11 @@     , mkDispatchInstance      , mkYesodSubDispatch+    , mkYesodSubDispatchInstance+    , mkYesodSubDispatchInstanceOpts+    , mkNestedSubDispatchInstance      , subTopDispatch-    , instanceD      , RouteOpts     , defaultOpts@@ -43,30 +46,28 @@     , 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.Content (ToTypedContent (..)) 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.@@ -125,6 +126,15 @@ 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@@ -143,40 +153,9 @@                       -> [ResourceTree String]                       -> Q([Dec],[Dec]) mkYesodWithParserOpts opts name isSub f resS = do-    let (name', rest, cxt) = case parse parseName "" name of-            Left err -> error $ show err-            Right a -> a-    mkYesodGeneralOpts opts cxt name' rest isSub f resS--    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+    (name', rest, cxt) <- parseYesodNameQ name -        parseContexts =-            sepBy1 (many1 parseWord) (spaces >> char ',' >> return ())+    mkYesodGeneralOpts opts cxt name' rest isSub f resS   -- | See 'mkYesodData'.@@ -190,6 +169,17 @@ 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 =@@ -209,11 +199,84 @@                -> Q([Dec],[Dec]) 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 <- 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"+    let boundNames = fmap nameToType mtys+        argtypes = fmap fst boundNames ++ fmap VarT vns+        site = foldl' AppT (ConT name) argtypes+    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]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.+                   -> [[String]]                -- ^ Application context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.                    -> String                    -- ^ foundation type                    -> [String]                  -- ^ arguments for the type                    -> Bool                      -- ^ is this a subsite@@ -221,41 +284,52 @@                    -> [ResourceTree String]                    -> Q([Dec],[Dec]) mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do-    let appCxt = fmap (\ctxs ->-            case ctxs of-                c:rest ->-                    foldl' (\acc v -> acc `AppT` fst (nameToType v)) (ConT $ mkName c) rest-                [] -> error $ "Bad context: " ++ show ctxs-          ) appCxt'-    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-    let name = mkName namestr-    -- Generate as many variable names as the arity indicates-    vns <- replicateM (arity - length mtys) $ newName "t"-    -- types that you apply to get a concrete site name-    let boundNames = fmap nameToType mtys-        argtypes = fmap fst boundNames ++ fmap VarT vns+    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 ++ vns-        -- Base type (site type with variables)-    let site = foldl' AppT (ConT name) argtypes-        res = map (fmap (parseType . dropBracket)) resS-    renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt boundNames site res-    routeAttrsDec  <- mkRouteAttrsInstance appCxt site res-    dispatchDec    <- mkDispatchInstance site appCxt f res-    parseRoute <- mkParseRouteInstance appCxt site res+    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     resourcesDec <-         if shouldCreateResources opts@@ -268,99 +342,149 @@             else do                 pure []     let dataDec = concat-            [ [parseRoute]+            [ parseRouteDec             , renderRouteDec-            , [routeAttrsDec]-            , resourcesDec-            , if isSub then [] else masterTypeSyns argvars site+            , routeAttrsDec+            , if isJust (roFocusOnNestedRoute opts) then [] else resourcesDec+            , if isSub || isJust (roFocusOnNestedRoute opts)+                then []+                else masterTypeSyns argvars (rfSite foundation)             ]     return (dataDec, dispatchDec) +-- | 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 -mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b-mkMDS f rh sd = MkDispatchSettings-    { mdsRunHandler = rh-    , mdsSubDispatcher = sd-    , mdsGetPathInfo = [|W.pathInfo|]-    , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]-    , mdsMethod = [|W.requestMethod|]-    , mds404 = [|void notFound|]-    , mds405 = [|void badMethod|]-    , mdsGetHandler = defaultGetHandler-    , mdsUnwrapper = f-    }+-- | 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 --- | 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|]-                [|\parentRunner getSub toParent env -> yesodSubDispatch-                    YesodSubRunnerEnv-                    { ysreParentRunner = parentRunner-                    , ysreGetSub = getSub-                    , ysreToParentRoute = toParent-                    , ysreParentEnv = env-                    }-                |])-            res-    let thisDispatch = FunD 'yesodDispatch [clause']-    return [instanceD cxt yDispatch [thisDispatch]]-  where-    yDispatch = ConT ''YesodDispatch `AppT` master+    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 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) -mkYesodSubDispatch :: [ResourceTree a] -> Q Exp-mkYesodSubDispatch res = do-    clause' <--        mkDispatchClause-            (mkMDS-                return-                [|subHelper|]-                [|subTopDispatch|])-        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)+    -- 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 ] -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-            })+    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) -instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing+    return $ yesodSubDispatchInst : nestedInstances

@@ -13,7 +13,7 @@     -- 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`.-+    -- `ToContent` data in `DontFullyEvaluate`.     | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())     | ContentFile !FilePath !(Maybe FilePart)     | ContentDontEvaluate !Content

@@ -1,14 +1,23 @@ {-# 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.@@ -16,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

@@ -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

@@ -9,9 +9,11 @@     , parseRoutesNoCheck     , parseRoutesFileNoCheck     , parseType+    , parseTypeM     , parseTypeTree     , TypeTree (..)     , dropBracket+    , dropBracketM     , nameToType     , isTvar     ) where@@ -33,10 +35,10 @@ 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. --@@ -65,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@@ -94,58 +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, check) =-                            case piecesFromStringCheck pattern of-                                (p, Nothing, c) -> (p, c)-                                -- FIXME: Give better error message-                                _ -> error "Invalid resource line: bad overlap"-                     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 "" = ("", "")+        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) @@ -154,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 }@@ -181,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@@ -280,28 +293,41 @@ isTvar (h:_) = isLower h isTvar _     = False -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)+-- | '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 (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 (True, x)+pieceFromString ('+':x) = pure $ Left (True, x) -pieceFromString ('!':x) = Right $ (False, Static x)-pieceFromString x = Right $ (True, Static 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. --

@@ -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

@@ -1,213 +1,1054 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE 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) (conPCompat '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 = conPCompat '(:) [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 (conPCompat '[] [], Nothing)-                            Just _ -> do-                                multiName <- newName "multi"-                                let pat = ViewP (VarE 'fromPathMultiPiece)-                                                (conPCompat '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--conPCompat :: Name -> [Pat] -> Pat-conPCompat n pats = ConP n-#if MIN_VERSION_template_haskell(2,18,0)-                         []-#endif-                         pats+{-# 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 ())

@@ -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)

@@ -1,48 +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) []]

@@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskellQuotes #-}+-- '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 #-} @@ -8,7 +11,6 @@     ( -- ** RenderRoute       mkRenderRouteInstanceOpts     , mkRouteConsOpts-    , mkRenderRouteClauses     , shouldCreateResources      , RouteOpts@@ -17,17 +19,28 @@     , 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 Data.Maybe (maybeToList)-import Control.Monad (replicateM)+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. --@@ -43,14 +56,38 @@     , 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. ----- Defaults to all instances derived, subroutes being unparameterized, and to--- create the @resourcesSite :: [ResourceTree String]@ term.+-- 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@@ -59,22 +96,117 @@     , 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 }@@ -86,6 +218,8 @@ -- 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 }@@ -97,8 +231,24 @@ shouldCreateResources :: RouteOpts -> Bool shouldCreateResources = roCreateResources --- | If True, we will correctly pass parameters for subroutes around.+-- | 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 }@@ -110,106 +260,362 @@ instanceNamesFromOpts MkRouteOpts {..} = prependIf roDerivedEq ''Eq $ prependIf roDerivedShow ''Show $ prependIf roDerivedRead ''Read []     where prependIf b = if b then (:) else const id --- | Nullify the list unless we are using parameterised subroutes.-nullifyWhenNoParam :: RouteOpts -> [a] -> [a]-nullifyWhenNoParam opts = if roParameterizedSubroute opts then id else const []+-- | 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) --- | Generate the constructors of a route data type, with custom opts.+-- | Classify how a route datatype's children should be generated, given the+-- site's route options and its 'TyArgs'. ----- @since 1.6.25.0-mkRouteConsOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> [ResourceTree Type] -> ([Con], [Dec])-mkRouteConsOpts opts cxt (nullifyWhenNoParam opts -> tyargs) =-    mkRouteConsOpts'-  where-    -- th-abstraction does cover this but the version it was introduced in-    -- isn't always available-    tyvarbndr =+-- '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)-        (`PlainTV` BndrReq) :: Name -> TyVarBndr BndrVis+    TyVarBndr BndrVis #elif MIN_VERSION_template_haskell(2,17,0)-        (`PlainTV` ()) :: Name -> TyVarBndr ()+    TyVarBndr () #else-        PlainTV :: Name -> TyVarBndr+    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 -    subrouteDecTypeArgs = fmap (tyvarbndr . snd) tyargs+-- | 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]+            _ -> [] -    (inlineDerives, mkSds) = getDerivesFor opts (nullifyWhenNoParam opts cxt)+-- | 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] -    mkRouteConsOpts' :: [ResourceTree Type] -> ([Con], [Dec])-    mkRouteConsOpts' = foldMap mkRouteCon+-- | 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        = [] -    mkRouteCon (ResourceLeaf res) =-        ([con], [])-      where-        con = NormalC (mkName $ resourceName res)-            $ map (notStrict,)-            $ concat [singles, multi, sub]-        singles = concatMap toSingle $ resourcePieces res-        toSingle Static{} = []-        toSingle (Dynamic typ) = [typ]+-- | 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) -        multi = maybeToList $ resourceMulti res+    -- Derives for the child (subroute) datatypes. See 'childDerivCxt'.+    childCxt = childDerivCxt tyargs cxt+    (inlineDerives, mkStandaloneDerives) = getDerivesFor opts childCxt -        sub =-            case resourceDispatch res of-                Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]-                _ -> []+    mkRouteConsOpts' :: [Piece Type] -> [ResourceTree Type] -> Q ([Con], [Dec])+    mkRouteConsOpts' prePieces trees = do+        results <- mapM (mkRouteCon prePieces) trees+        pure (mconcat results) -    mkRouteCon (ResourceParent name _check pieces children) =-        let (cons, decs) = mkRouteConsOpts' children-            dec = DataD [] dataName subrouteDecTypeArgs Nothing cons inlineDerives-        in ([con], dec : decs ++ mkSds consDataType)+    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-        con = NormalC dataName-            $ map (notStrict,)-            $ singles ++ [consDataType]+        mkChildDataGen :: Name -> [Con] -> [DerivClause] -> Dec+        mkChildDataGen childDataName cons conts =+            DataD [] childDataName subrouteDecTypeArgs Nothing cons conts -        singles = concatMap toSingle pieces-        toSingle Static{} = []-        toSingle (Dynamic typ) = [typ]+-- | 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]) -        dataName = mkName name-        consDataType = foldl' (\b a -> b `AppT` fst a) (ConT dataName) tyargs+-- | Is this path piece a dynamic capture, as opposed to a static segment?+isDynamic :: Piece t -> Bool+isDynamic Dynamic{} = True+isDynamic _ = False --- | Clauses for the 'renderRoute' method.-mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]-mkRenderRouteClauses =-    mapM go+-- | 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-    isDynamic Dynamic{} = True-    isDynamic _ = False+    goList = fmap mconcat . mapM go -    go (ResourceParent name _check pieces children) = do-        let cnt = length $ filter isDynamic pieces+    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"-        child <- newName "child"-        let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child]+        sub <-+            case resourceDispatch res of+                Subsite{} -> return <$> newName "sub"+                _ -> return []+        let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub          pack' <- [|pack|]         tsp <- [|toPathPiece|]-        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns+        piecesSingle <- mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns -        childRender <- newName "childRender"-        let rr = VarE childRender-        childClauses <- mkRenderRouteClauses children+        piecesMulti <-+            case resourceMulti res of+                Nothing -> return $ ListE []+                Just{} -> do+                    tmp <- [|toPathMultiPiece|]+                    return $ tmp `AppE` VarE (last dyns) -        a <- newName "a"-        b <- newName "b"+        body <-+            case sub of+                [x] -> do+                    rr <- [|renderRoute|]+                    delegatingBody piecesSingle rr (VarE x)+                _ ->+                    return $ mkTupE [foldr consE piecesMulti piecesSingle, ListE []] -        colon <- [|(:)|]-        let cons y ys = InfixE (Just y) colon (Just ys)-        let pieces' = foldr cons (VarE a) piecesSingle+        return [Clause [pat] (NormalB body) []] -        let body = LamE [TupP [VarP a, VarP b]] (TupE-#if MIN_VERSION_template_haskell(2,16,0)-                                                  $ map Just-#endif-                                                  [pieces', VarE b]-                                                ) `AppE` (rr `AppE` VarE child)+-- | 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) )+        |] -        return $ Clause [pat] (NormalB body) [FunD childRender childClauses]+-- | 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"@@ -221,8 +627,16 @@          pack' <- [|pack|]         tsp <- [|toPathPiece|]-        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns +        -- 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 []@@ -234,35 +648,62 @@             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-#if MIN_VERSION_template_haskell(2,16,0)-                                                            $ map Just-#endif-                                                            [pieces, VarE b]-                                                          ) `AppE` (rr `AppE` VarE x)+                    -- 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)-                    return $ TupE-#if MIN_VERSION_template_haskell(2,16,0)-                      $ map Just-#endif-                      [foldr cons piecesMulti piecesSingle, ListE []]+                    -- Combine parent pieces with this resource's pieces+                    let allPieces = parentPieces ++ thisResourcePieces+                    return $ mkTupE [foldr cons piecesMulti allPieces, ListE []] -        return $ Clause [pat] (NormalB body) []+        return [Clause [parentArgsPat parentDyns, 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"+    -- 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@@ -270,25 +711,53 @@ -- 'mkRenderRouteClauses'. -- -- @since 1.6.25.0-mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> [(Type, Name)] -> Type -> [ResourceTree Type] -> Q [Dec]+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-    cls <- mkRenderRouteClauses ress-    let (cons, decs) = mkRouteConsOpts opts cxt tyargs ress-    let did = DataInstD []+    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+                    Nothing routeDataName #else-            ''Route [typ]+                    ''Route [typ] #endif-            Nothing cons inlineDerives-    return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)-        [ did-        , FunD (mkName "renderRoute") cls-        ]-        : mkSds routeDataName ++ decs+                    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, mkSds) = getDerivesFor opts cxt+    (inlineDerives, mkStandaloneDerives) = getDerivesFor opts cxt  -- | Get the simple derivation clauses and the standalone derivation clauses -- for a given type and context.@@ -297,20 +766,214 @@ -- 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+    | 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 -instanceD :: Cxt -> Type -> [Dec] -> Dec-instanceD = InstanceD Nothing+-- | 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+        ] -conPCompat :: Name -> [Pat] -> Pat-conPCompat n pats = ConP n-#if MIN_VERSION_template_haskell(2,18,0)-                         []-#endif-                         pats+-- | 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)

@@ -1,47 +1,117 @@-{-# LANGUAGE CPP #-} {-# 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)-#if MIN_VERSION_template_haskell(2,18,0)-                          []-#endif+    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)

@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveLift #-}  -- | Warning! This module is considered internal and may have breaking changes@@ -10,6 +12,16 @@     , Dispatch (..)     , CheckOverlap     , FlatResource (..)+    , ParentDetails (..)+      -- * Route datatype type arguments+    , TyArgs (..)+    , toTyArgs+    , tyArgsList+    , tyArgsTypes+    , tyArgsBinders+    , tyArgsArity+    , hasTyArgs+    , applyTyArgs       -- ** Helper functions     , resourceMulti     , resourceTreePieces@@ -18,19 +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 (Lift, 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+resourceTreeName (ResourceParent x _ _ _ _) = x  data Resource typ = Resource     { resourceName :: String@@ -39,16 +120,12 @@     , resourceAttrs :: [String]     , resourceCheck :: CheckOverlap     }-    deriving (Lift, Show, Functor)+    deriving (Lift, Show, Functor, Foldable, Traversable)  type CheckOverlap = Bool  data Piece typ = Static String | Dynamic typ-    deriving (Lift, Show)--instance Functor Piece where-    fmap _ (Static s)  = Static s-    fmap f (Dynamic t) = Dynamic (f t)+    deriving (Lift, Show, Functor, Foldable, Traversable)  data Dispatch typ =     Methods@@ -59,18 +136,25 @@         { subsiteType :: typ         , subsiteFunc :: String         }-    deriving (Lift, Show)--instance Functor Dispatch where-    fmap f (Methods a b) = Methods (fmap f a) b-    fmap f (Subsite a b) = Subsite (f a) 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@@ -81,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

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -9,174 +10,100 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# 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 <- mkRenderRouteInstanceOpts defaultOpts [] [] (ConT ''Hierarchy) $ map (fmap parseType) resources-    rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources-    prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources-    dispatch <- mkDispatchClause MkDispatchSettings-        { 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 $-        InstanceD-            Nothing-            []-            (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" $@@ -185,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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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]

@@ -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

@@ -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)

@@ -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"]

@@ -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)

@@ -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

@@ -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)

@@ -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"], [])

@@ -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")+                        ]

@@ -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"

@@ -11,20 +11,36 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns#-}--- {-# OPTIONS_GHC -ddump-splices #-} +-- | 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 @@ -47,180 +63,72 @@         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 <- mkRenderRouteInstanceOpts defaultOpts [] [] (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 $-        InstanceD-            Nothing-            []-            (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@@ -314,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@@ -333,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

@@ -11,6 +11,26 @@ 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@@ -23,6 +43,8 @@ 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 #ifndef WINDOWS@@ -48,6 +70,7 @@       linksTest       noOverloadedTest       subSubTest+      splitSubsiteSpec       internalRequestTest       errorHandlingTest       cacheTest@@ -72,3 +95,23 @@       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

@@ -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")

@@ -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+|]

@@ -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")