From febee0ce1dca539fc90af5e17d04dac3cfb7d3da Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Fri, 15 Mar 2024 22:44:00 +0100 Subject: [PATCH] Fix breadcrumbs Issue: The breadcrumbs should link to the home page, but they currently link to the current page. The cause is that the `breadcrumbsField` function looks up the `"nav"` version of the parents, and then `indexlessUrlField` looks up their URL using `getRoute`, but the `"nav"` versions of the pages have no route. The fix is to use the default version of the parents instead. List of changes: 1. Remove now unused `"nav"` versions of the pages. I am guessing that the original reason for adding `"nav"` versions was to avoid a circular dependency (so that the message pages can link to the homepage which links to the messages). The dependency was introduced by the `load` function. But we can get the URL and title for the breadcrumbs without `load`. 2. Remove the `breadcrumbFields` function. On top of creating the "parents" field for the breadcrumbs, it adds a `messageTitleField` which appends the [GHC-XXXXXX] identifier. This was used in the messages pages and also the home page, where it just leaves the title unchanged. But that title was already available in `defaultContext`. Instead we add `messageTitleField` only in the messages pages and in the breadcrumbs (just in case, this is currently unused). 3. Simplify `breadcrumbCtx` to only get the url and title. 4. Refactor `indexlessUrlField` by reusing `urlField`. 5. Refactor `indexless` with an auxiliary `stripSuffix`. 6. Remove unused `breadcrumbField` in the `messages/examples/` pages. --- message-index/site.hs | 51 +++++++++++++------------------------------ 1 file changed, 15 insertions(+), 36 deletions(-) diff --git a/message-index/site.hs b/message-index/site.hs index c77eb49e..56893cb8 100644 --- a/message-index/site.hs +++ b/message-index/site.hs @@ -12,7 +12,7 @@ import Data.Data (Typeable) import Data.Foldable (for_) import Data.Function (on) import Data.Functor ((<&>)) -import Data.List (find, isPrefixOf, lookup, nub, sort, sortBy) +import Data.List (find, lookup, nub, sort, sortBy, stripPrefix) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -54,10 +54,6 @@ main = hakyll $ do route idRoute compile copyFileCompiler - match "messages/*/*/index.md" $ - version "nav" $ do - compile getResourceBody - match "messages/*/*/index.md" $ do route $ setExtension "html" compile $ do @@ -66,7 +62,6 @@ main = hakyll $ do getUnderlying <&> \ident -> fromFilePath $ takeDirectory (takeDirectory (toFilePath ident)) "index.md" - bread <- breadcrumbField ["index.html", thisMessage] pandocCompiler >>= loadAndApplyTemplate "templates/example.html" @@ -91,15 +86,11 @@ main = hakyll $ do ) >>= relativizeUrls - match "messages/*/index.md" $ - version "nav" $ do - compile pandocCompiler - match "messages/*/index.md" $ do route $ setExtension "html" compile $ do examples <- getExamples - bread <- breadcrumbField ["index.html"] + let bread = breadcrumbCtx ["index.html"] pandocCompiler >>= loadAndApplyTemplate "templates/message.html" @@ -111,7 +102,7 @@ main = hakyll $ do defaultContext ] ) - >>= loadAndApplyTemplate "templates/default.html" (bread <> defaultContext) + >>= loadAndApplyTemplate "templates/default.html" (bread <> messageTitleField <> defaultContext) >>= relativizeUrls match "messages/index.md" $ do @@ -121,22 +112,18 @@ main = hakyll $ do match "404.html" $ do route idRoute compile $ do - bread <- breadcrumbField ["index.html"] - let ctx = mconcat [constField "title" "Not Found", bread, defaultContext] + let bread = breadcrumbCtx ["index.html"] + ctx = mconcat [constField "title" "Not Found", bread, defaultContext] getResourceBody >>= applyAsTemplate ctx >>= loadAndApplyTemplate "templates/default.html" ctx - match "index.html" $ - version "nav" $ do - compile getResourceBody - match "index.html" $ do route idRoute compile $ do messages <- loadAll ("messages/*/index.md" .&&. hasNoVersion) - bread <- breadcrumbField [] - let indexCtx = + let bread = breadcrumbCtx [] + indexCtx = mconcat [ listField "messages" (messageCtx <> defaultContext) (pure messages), bread, @@ -161,19 +148,13 @@ main = hakyll $ do exampleExtensions :: NonEmpty String exampleExtensions = "hs" :| ["yaml", "cabal"] -breadcrumbField :: [Identifier] -> Compiler (Context String) -breadcrumbField idents = - (messageTitleField <>) . breadcrumbCtx <$> traverse (load @String . setVersion (Just "nav")) idents - -breadcrumbCtx :: [Item String] -> Context String +breadcrumbCtx :: [Identifier] -> Context String breadcrumbCtx parents = - listField "parents" (mconcat [indexlessUrlField "url", messageTitleField, defaultContext]) (pure parents) + let parents' = (\i -> Item i ()) <$> parents in + listField "parents" (indexlessUrlField "url" <> messageTitleField) (pure parents') indexlessUrlField :: String -> Context a -indexlessUrlField key = field key $ \i -> - let id = itemIdentifier i - empty' = fail $ "No route url found for item " ++ show id - in maybe empty' (indexless . toUrl) <$> getRoute id +indexlessUrlField = mapContext indexless . urlField messageTitleField :: Context String messageTitleField = field "title" getTitle @@ -301,9 +282,7 @@ flagSetFields = ] indexless :: String -> String -indexless url - | reverse toDrop `isPrefixOf` lru = reverse $ drop (length toDrop) lru - | otherwise = url - where - lru = reverse url - toDrop = "index.html" +indexless url = fromMaybe url (stripSuffix "index.html" url) + +stripSuffix :: String -> String -> Maybe String +stripSuffix suffix src = reverse <$> stripPrefix (reverse suffix) (reverse src)