1019 lines
49 KiB
Haskell
1019 lines
49 KiB
Haskell
{-# LANGUAGE GHC2021 #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
module Site (rules) where
|
||
|
||
import Control.Monad (forM, forM_, when)
|
||
import Data.Char (isSpace, toUpper)
|
||
import Data.List (groupBy, isPrefixOf, sort, sortBy)
|
||
import Data.Map.Strict (Map)
|
||
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
||
import Data.Ord (Down (..), comparing)
|
||
import Data.Set (Set)
|
||
import qualified Data.Set as Set
|
||
import qualified Data.Text as T
|
||
import System.Directory (listDirectory)
|
||
import System.Environment (lookupEnv)
|
||
import System.FilePath (takeDirectory, takeFileName, takeExtension, replaceExtension, (</>))
|
||
import Text.Read (readMaybe)
|
||
import qualified Data.Aeson as Aeson
|
||
import qualified Data.ByteString.Lazy.Char8 as LBS
|
||
import qualified Data.Map.Strict as Map
|
||
import Hakyll
|
||
import Authors (buildAllAuthors, applyAuthorRules)
|
||
import Backlinks (backlinkRules)
|
||
import BibExtras (BibExtra (..), emptyBibExtra, firstAuthorSurname, parseBibExtras)
|
||
import Citations (renderBibliographyHtml)
|
||
import Compilers (essayCompiler, postCompiler, pageCompiler, poetryCompiler, fictionCompiler,
|
||
compositionCompiler, sidecarCompiler)
|
||
import Catalog (musicCatalogCtx)
|
||
import Commonplace (commonplaceCtx)
|
||
import Now (nowCtx)
|
||
import Contexts (siteCtx, essayCtx, postCtx, pageCtx, poetryCtx, fictionCtx, compositionCtx,
|
||
contentKindField, recentFirstByDisplay,
|
||
tagLinksFieldExcludingTopSegment)
|
||
import qualified Patterns as P
|
||
import Tags (buildAllTags, applyTagRules, sidecarIdentifier,
|
||
portalIntroField, portalTooltipField)
|
||
import Pagination (blogPaginateRules)
|
||
import Stats (statsRules)
|
||
|
||
-- | Home-page portal grid order. Canonical ordering authority for every
|
||
-- rendering of the eight portals (currently: the home page; future
|
||
-- consumers follow this list). Each entry is (display name, tag name);
|
||
-- the tag name is the key to everything else — URL (@/\<tag\>/@),
|
||
-- sidecar path (@content\/tag-meta\/\<tag\>.md@), and the Tags.hs
|
||
-- machinery that already keys off it. Edit this list to change order;
|
||
-- do not introduce an @order:@ frontmatter field on sidecars.
|
||
homePortals :: [(String, String)]
|
||
homePortals =
|
||
[ ("Research", "research")
|
||
, ("Nonfiction", "nonfiction")
|
||
, ("Fiction", "fiction")
|
||
, ("Poetry", "poetry")
|
||
, ("Music", "music")
|
||
, ("AI", "ai")
|
||
, ("Tech", "tech")
|
||
, ("Miscellany", "miscellany")
|
||
]
|
||
|
||
-- | Default number of cards shown per library shelf. The sidecar
|
||
-- 'featured:' list may push this up to 'libraryShelfMax'.
|
||
libraryShelfCap :: Int
|
||
libraryShelfCap = 4
|
||
|
||
-- | Hard ceiling on cards per shelf, regardless of sidecar length.
|
||
libraryShelfMax :: Int
|
||
libraryShelfMax = 5
|
||
|
||
-- | Optional prose intro lifted into @$library-intro$@ on the library
|
||
-- page. Matched but not routed; consumed via the @"body"@ snapshot.
|
||
libraryIntroId :: Identifier
|
||
libraryIntroId = fromFilePath "content/library.md"
|
||
|
||
-- Poems inside collection subdirectories, excluding their index pages.
|
||
collectionPoems :: Pattern
|
||
collectionPoems = "content/poetry/*/*.md" .&&. complement "content/poetry/*/index.md"
|
||
|
||
-- All poetry content (flat + collection), excluding collection index pages.
|
||
allPoetry :: Pattern
|
||
allPoetry = "content/poetry/*.md" .||. collectionPoems
|
||
|
||
feedConfig :: FeedConfiguration
|
||
feedConfig = FeedConfiguration
|
||
{ feedTitle = "Levi Neuwirth"
|
||
, feedDescription = "Essays, notes, and creative work by Levi Neuwirth"
|
||
, feedAuthorName = "Levi Neuwirth"
|
||
, feedAuthorEmail = "levi@levineuwirth.org"
|
||
, feedRoot = "https://levineuwirth.org"
|
||
}
|
||
|
||
musicFeedConfig :: FeedConfiguration
|
||
musicFeedConfig = FeedConfiguration
|
||
{ feedTitle = "Levi Neuwirth — Music"
|
||
, feedDescription = "New compositions by Levi Neuwirth"
|
||
, feedAuthorName = "Levi Neuwirth"
|
||
, feedAuthorEmail = "levi@levineuwirth.org"
|
||
, feedRoot = "https://levineuwirth.org"
|
||
}
|
||
|
||
-- | Context for the home page. Extends 'pageCtx' with a @portals@
|
||
-- listField iterating 'homePortals' in order. Each item exposes
|
||
-- @$portal-name$@, @$portal-url$@, and (if the sidecar's tooltip is
|
||
-- populated) @$portal-tooltip$@, consumed by @templates/home.html@.
|
||
-- Tooltip lookup uses 'portalTooltipField' — the same function
|
||
-- 'Tags.applyTagRules' uses on per-tag pages — so the two surfaces
|
||
-- stay in lockstep on suppression and missing-file semantics.
|
||
homeCtx :: Context String
|
||
homeCtx = listField "portals" portalItemCtx portalItems <> pageCtx
|
||
where
|
||
portalItems :: Compiler [Item (String, String)]
|
||
portalItems = return (map (Item (fromFilePath "")) homePortals)
|
||
|
||
portalItemCtx :: Context (String, String)
|
||
portalItemCtx =
|
||
field "portal-name" (return . fst . itemBody)
|
||
<> field "portal-url" (\i -> return $ "/" ++ snd (itemBody i) ++ "/")
|
||
<> portalTooltipField (sidecarIdentifier . snd . itemBody)
|
||
|
||
rules :: Rules ()
|
||
rules = do
|
||
-- ---------------------------------------------------------------------------
|
||
-- Build mode. SITE_ENV=dev (set by `make dev` / `make watch`) includes
|
||
-- drafts under content/drafts/**; anything else (unset, "deploy", "build")
|
||
-- excludes them entirely from every match, listing, and asset rule below.
|
||
-- ---------------------------------------------------------------------------
|
||
isDev <- preprocess $ (== Just "dev") <$> lookupEnv "SITE_ENV"
|
||
let allEssays = if isDev
|
||
then P.essayPattern .||. P.draftEssayPattern
|
||
else P.essayPattern
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Backlinks (pass 1: link extraction; pass 2: JSON generation)
|
||
-- Must run before content rules so dependencies resolve correctly.
|
||
-- ---------------------------------------------------------------------------
|
||
backlinkRules
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Author index pages
|
||
-- ---------------------------------------------------------------------------
|
||
authors <- buildAllAuthors
|
||
applyAuthorRules authors siteCtx
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Tag-meta sidecars — optional prose intros + tooltips for tag index
|
||
-- pages and the home-page portal grid. Matched but not routed: the
|
||
-- rendered body is exposed only via the @"body"@ snapshot and the
|
||
-- @tooltip:@ frontmatter key is read through 'getMetadata' by the
|
||
-- consumers (Tags.hs, home-page rule). Registered before tag rules so
|
||
-- snapshot loads during tag-page compilation find a compiled target.
|
||
--
|
||
-- Two-pattern union: Hakyll's @**/*@ glob requires at least one
|
||
-- subdirectory level, so flat sidecars (@content/tag-meta/nonfiction.md@)
|
||
-- and nested sidecars (@content/tag-meta/nonfiction/philosophy.md@) must
|
||
-- each be named by their own level-specific pattern.
|
||
-- ---------------------------------------------------------------------------
|
||
match ("content/tag-meta/*.md" .||. "content/tag-meta/**/*.md") $
|
||
compile sidecarCompiler
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Tag index pages
|
||
-- ---------------------------------------------------------------------------
|
||
tags <- buildAllTags
|
||
applyTagRules tags homePortals siteCtx
|
||
statsRules tags
|
||
|
||
-- Per-page JS files — authored alongside content in content/**/*.js.
|
||
-- Draft JS is handled by a separate dev-only rule below.
|
||
match ("content/**/*.js" .&&. complement "content/drafts/**") $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- Per-page JS co-located with draft essays (dev-only).
|
||
when isDev $ match "content/drafts/**/*.js" $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- CSS — must be matched before the broad static/** rule to avoid
|
||
-- double-matching (compressCssCompiler vs. copyFileCompiler).
|
||
match "static/css/*" $ do
|
||
route $ gsubRoute "static/" (const "")
|
||
compile compressCssCompiler
|
||
|
||
-- All other static files (fonts, JS, images, …)
|
||
match ("static/**" .&&. complement "static/css/*") $ do
|
||
route $ gsubRoute "static/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- Templates
|
||
match "templates/**" $ compile templateBodyCompiler
|
||
|
||
-- Link annotations — author-defined previews for any URL
|
||
match "data/annotations.json" $ do
|
||
route idRoute
|
||
compile copyFileCompiler
|
||
|
||
-- Semantic search index — produced by tools/embed.py; fetched at runtime
|
||
-- by static/js/semantic-search.js from /data/semantic-index.bin and
|
||
-- /data/semantic-meta.json.
|
||
match ("data/semantic-index.bin" .||. "data/semantic-meta.json") $ do
|
||
route idRoute
|
||
compile copyFileCompiler
|
||
|
||
-- Similar links — produced by tools/embed.py; absent on first build or
|
||
-- when .venv is not set up. Compiled as a raw string for similarLinksField.
|
||
match "data/similar-links.json" $ compile getResourceBody
|
||
|
||
-- Commonplace YAML — compiled as a raw string so it can be loaded
|
||
-- with dependency tracking by the commonplace page compiler.
|
||
match "data/commonplace.yaml" $ compile getResourceBody
|
||
|
||
-- Now YAML — same pattern as commonplace. Loaded by Now.nowCtx for
|
||
-- /current.html. Re-compiles current.html when the YAML changes.
|
||
match "data/now.yaml" $ compile getResourceBody
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Homepage
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/index.md" $ do
|
||
route $ constRoute "index.html"
|
||
compile $ pageCompiler
|
||
>>= loadAndApplyTemplate "templates/home.html" homeCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" homeCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Standalone pages (me/, colophon.md, …)
|
||
-- ---------------------------------------------------------------------------
|
||
-- me/index.md — compiled as a full essay (TOC, metadata block, sidenotes).
|
||
-- Lives in its own directory so co-located SVG score fragments resolve
|
||
-- correctly: the Score filter reads paths relative to the source file's
|
||
-- directory (content/me/), not the content root.
|
||
match "content/me/index.md" $ do
|
||
route $ constRoute "me.html"
|
||
compile $ essayCompiler
|
||
>>= loadAndApplyTemplate "templates/essay.html" essayCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" essayCtx
|
||
>>= relativizeUrls
|
||
|
||
-- SVG score fragments co-located with me/index.md.
|
||
match "content/me/scores/*.svg" $ do
|
||
route $ gsubRoute "content/me/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- memento-mori/index.md — lives in its own directory so co-located SVG
|
||
-- score fragments resolve correctly (same pattern as me/index.md).
|
||
match "content/memento-mori/index.md" $ do
|
||
route $ constRoute "memento-mori.html"
|
||
compile $ essayCompiler
|
||
>>= loadAndApplyTemplate "templates/essay.html"
|
||
(constField "memento-mori" "true" <> essayCtx)
|
||
>>= loadAndApplyTemplate "templates/default.html"
|
||
(constField "memento-mori" "true" <> essayCtx)
|
||
>>= relativizeUrls
|
||
|
||
-- SVG score fragments co-located with memento-mori/index.md.
|
||
match "content/memento-mori/scores/*.svg" $ do
|
||
route $ gsubRoute "content/memento-mori/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Commonplace book
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/commonplace.md" $ do
|
||
route $ constRoute "commonplace.html"
|
||
compile $ pageCompiler
|
||
>>= loadAndApplyTemplate "templates/commonplace.html" commonplaceCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" commonplaceCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Now — research-first status page driven by data/now.yaml. Same
|
||
-- structural pattern as the commonplace page: markdown body
|
||
-- (optional intro prose) + structured YAML rendered into HTML by
|
||
-- Now.nowCtx, then assembled by templates/current.html.
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/current.md" $ do
|
||
route $ constRoute "current.html"
|
||
compile $ pageCompiler
|
||
>>= loadAndApplyTemplate "templates/current.html" nowCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" nowCtx
|
||
>>= relativizeUrls
|
||
|
||
match "content/colophon.md" $ do
|
||
route $ constRoute "colophon.html"
|
||
compile $ essayCompiler
|
||
>>= loadAndApplyTemplate "templates/essay.html" essayCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" essayCtx
|
||
>>= relativizeUrls
|
||
|
||
match ("content/*.md"
|
||
.&&. complement "content/index.md"
|
||
.&&. complement "content/commonplace.md"
|
||
.&&. complement "content/colophon.md"
|
||
.&&. complement "content/current.md"
|
||
.&&. complement "content/library.md") $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
`composeRoutes` setExtension "html"
|
||
compile $ pageCompiler
|
||
>>= loadAndApplyTemplate "templates/page.html" pageCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" pageCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- CV routing pages (content/cv/*.md → /cv/<slug>/).
|
||
-- These are narrative overlays pointing into the library; they render
|
||
-- with the same page.html pipeline as top-level standalone pages, but
|
||
-- route to directory-style URLs (/cv/projects/ rather than /cv/projects.html)
|
||
-- so nginx serves them via index-file resolution and the URLs stay stable
|
||
-- if the underlying files are later reorganized into co-located directories.
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/cv/*.md" $ do
|
||
route $ customRoute $ \ident ->
|
||
let fname = takeFileName (toFilePath ident)
|
||
slug = takeWhile (/= '.') fname
|
||
in "cv/" ++ slug ++ "/index.html"
|
||
compile $ pageCompiler
|
||
>>= loadAndApplyTemplate "templates/page.html" pageCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" pageCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Essays — flat (content/essays/foo.md → essays/foo.html) and
|
||
-- directory-based (content/essays/slug/index.md → essays/slug/index.html).
|
||
-- In dev mode, drafts under content/drafts/essays/ route to
|
||
-- drafts/essays/foo.html (flat) or drafts/essays/slug/index.html (dir).
|
||
-- ---------------------------------------------------------------------------
|
||
match allEssays $ do
|
||
route $ customRoute $ \ident ->
|
||
let fp = toFilePath ident
|
||
fname = takeFileName fp
|
||
isIndex = fname == "index.md"
|
||
isDraft = "content/drafts/essays/" `isPrefixOf` fp
|
||
in case (isDraft, isIndex) of
|
||
-- content/drafts/essays/slug/index.md → drafts/essays/slug/index.html
|
||
(True, True) -> replaceExtension (drop 8 fp) "html"
|
||
-- content/drafts/essays/foo.md → drafts/essays/foo.html
|
||
(True, False) -> "drafts/essays/" ++ replaceExtension fname "html"
|
||
-- content/essays/slug/index.md → essays/slug/index.html
|
||
(False, True) -> replaceExtension (drop 8 fp) "html"
|
||
-- content/essays/foo.md → essays/foo.html
|
||
(False, False) -> "essays/" ++ replaceExtension fname "html"
|
||
compile $ essayCompiler
|
||
>>= saveSnapshot "content"
|
||
>>= loadAndApplyTemplate "templates/essay.html" essayCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" essayCtx
|
||
>>= relativizeUrls
|
||
|
||
-- Static assets co-located with directory-based essays (figures, data, PDFs, …)
|
||
match ("content/essays/**"
|
||
.&&. complement "content/essays/*.md"
|
||
.&&. complement "content/essays/*/index.md") $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- Static assets co-located with draft essays (dev-only).
|
||
when isDev $ match ("content/drafts/essays/**"
|
||
.&&. complement "content/drafts/essays/*.md"
|
||
.&&. complement "content/drafts/essays/*/index.md") $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Blog posts
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/blog/*.md" $ do
|
||
route $ gsubRoute "content/blog/" (const "blog/")
|
||
`composeRoutes` setExtension "html"
|
||
compile $ postCompiler
|
||
>>= saveSnapshot "content"
|
||
>>= loadAndApplyTemplate "templates/blog-post.html" postCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" postCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Poetry
|
||
-- ---------------------------------------------------------------------------
|
||
-- Flat poems (e.g. content/poetry/sonnet-60.md)
|
||
match "content/poetry/*.md" $ do
|
||
route $ gsubRoute "content/poetry/" (const "poetry/")
|
||
`composeRoutes` setExtension "html"
|
||
compile $ poetryCompiler
|
||
>>= saveSnapshot "content"
|
||
>>= loadAndApplyTemplate "templates/reading.html" poetryCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" poetryCtx
|
||
>>= relativizeUrls
|
||
|
||
-- Collection poems (e.g. content/poetry/shakespeare-sonnets/sonnet-1.md)
|
||
match collectionPoems $ do
|
||
route $ gsubRoute "content/poetry/" (const "poetry/")
|
||
`composeRoutes` setExtension "html"
|
||
compile $ poetryCompiler
|
||
>>= saveSnapshot "content"
|
||
>>= loadAndApplyTemplate "templates/reading.html" poetryCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" poetryCtx
|
||
>>= relativizeUrls
|
||
|
||
-- Collection index pages (e.g. content/poetry/shakespeare-sonnets/index.md)
|
||
match "content/poetry/*/index.md" $ do
|
||
route $ gsubRoute "content/poetry/" (const "poetry/")
|
||
`composeRoutes` setExtension "html"
|
||
compile $ pageCompiler
|
||
>>= loadAndApplyTemplate "templates/default.html" pageCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Fiction
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/fiction/*.md" $ do
|
||
route $ gsubRoute "content/fiction/" (const "fiction/")
|
||
`composeRoutes` setExtension "html"
|
||
compile $ fictionCompiler
|
||
>>= saveSnapshot "content"
|
||
>>= loadAndApplyTemplate "templates/reading.html" fictionCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" fictionCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Music — catalog index
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/music/index.md" $ do
|
||
route $ constRoute "music/index.html"
|
||
compile $ pageCompiler
|
||
>>= loadAndApplyTemplate "templates/music-catalog.html" musicCatalogCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" musicCatalogCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Music — composition landing pages + score reader
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- Static assets (SVG score pages, audio, PDF) served unchanged.
|
||
match "content/music/**/*.svg" $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
match "content/music/**/*.mp3" $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
match "content/music/**/*.pdf" $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
compile copyFileCompiler
|
||
|
||
-- Landing page — full essay pipeline.
|
||
match "content/music/*/index.md" $ do
|
||
route $ gsubRoute "content/" (const "")
|
||
`composeRoutes` setExtension "html"
|
||
compile $ compositionCompiler
|
||
>>= saveSnapshot "content"
|
||
>>= loadAndApplyTemplate "templates/composition.html" compositionCtx
|
||
>>= loadAndApplyTemplate "templates/default.html" compositionCtx
|
||
>>= relativizeUrls
|
||
|
||
-- Score reader — separate URL, minimal chrome.
|
||
-- Compiled from the same source with version "score-reader".
|
||
match "content/music/*/index.md" $ version "score-reader" $ do
|
||
route $ customRoute $ \ident ->
|
||
let slug = takeFileName . takeDirectory . toFilePath $ ident
|
||
in "music/" ++ slug ++ "/score/index.html"
|
||
compile $ do
|
||
makeItem ""
|
||
>>= loadAndApplyTemplate "templates/score-reader.html"
|
||
compositionCtx
|
||
>>= loadAndApplyTemplate "templates/score-reader-default.html"
|
||
compositionCtx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Blog index (paginated)
|
||
-- ---------------------------------------------------------------------------
|
||
blogPaginateRules postCtx siteCtx
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Essay index
|
||
-- ---------------------------------------------------------------------------
|
||
create ["essays/index.html"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
essays <- recentFirst =<< loadAll (allEssays .&&. hasNoVersion)
|
||
let ctx =
|
||
listField "essays" essayCtx (return essays)
|
||
<> constField "title" "Essays"
|
||
<> siteCtx
|
||
makeItem ""
|
||
>>= loadAndApplyTemplate "templates/essay-index.html" ctx
|
||
>>= loadAndApplyTemplate "templates/default.html" ctx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- New page — all content sorted by creation date, newest first
|
||
-- ---------------------------------------------------------------------------
|
||
create ["new.html"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
let allContent = ( allEssays
|
||
.||. "content/blog/*.md"
|
||
.||. "content/fiction/*.md"
|
||
.||. allPoetry
|
||
.||. "content/music/*/index.md"
|
||
) .&&. hasNoVersion
|
||
items <- recentFirstByDisplay =<< loadAll allContent
|
||
let itemCtx = contentKindField
|
||
<> essayCtx
|
||
ctx = listField "recent-items" itemCtx (return items)
|
||
<> constField "title" "New"
|
||
<> constField "list-page" "true"
|
||
<> siteCtx
|
||
makeItem ""
|
||
>>= loadAndApplyTemplate "templates/new.html" ctx
|
||
>>= loadAndApplyTemplate "templates/default.html" ctx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Library intro — optional prose block (typically a blockquote) lifted
|
||
-- into @$library-intro$@ at the top of /library.html. Matched but not
|
||
-- routed; the body snapshot is consumed by the library rule below.
|
||
-- ---------------------------------------------------------------------------
|
||
match "content/library.md" $ compile sidecarCompiler
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Library — portal-grouped view over the /new.html dataset, deduplicated
|
||
-- by primary portal. An item's primary portal is the top segment of the
|
||
-- first tag in its frontmatter 'tags:' list whose top segment matches a
|
||
-- known portal (the eight in 'homePortals'). Items with no such tag are
|
||
-- silently dropped from the library (they remain on /new.html and on any
|
||
-- tag pages their frontmatter produces).
|
||
--
|
||
-- Each shelf is capped at 'libraryShelfCap' items by default. A portal's
|
||
-- tag-meta sidecar may carry a 'featured:' list of content-rooted paths
|
||
-- (e.g. @content/essays/foo.md@); featured items are placed first, in
|
||
-- listed order, and the remainder is filled by recency up to a hard
|
||
-- ceiling of 'libraryShelfMax'. Featured paths that don't resolve to an
|
||
-- item in the portal (wrong primary portal, or typo) are silently
|
||
-- dropped. When the unfiltered portal has more items than the shelf
|
||
-- shows, @$<slug>-has-more$@ is exposed so the template can render a
|
||
-- "More on this shelf →" affordance linking to the portal's tag page.
|
||
--
|
||
-- Each card uses the shared item-card partial, with cross-portal filings
|
||
-- rendered in the card's tag footer via 'tagLinksFieldExcludingTopSegment',
|
||
-- scoped to the section's portal so the portal's own tag is suppressed.
|
||
-- ---------------------------------------------------------------------------
|
||
create ["library.html"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
sidecarIds <- getMatches ("content/tag-meta/*.md"
|
||
.||. "content/tag-meta/**/*.md")
|
||
let sidecarSet = Set.fromList sidecarIds
|
||
knownPortals = map snd homePortals
|
||
|
||
-- Top segment of the first tag that names a known portal.
|
||
-- Nothing when no tag matches — item is excluded from library.
|
||
primaryPortalOf item = do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let ts = fromMaybe [] (lookupStringList "tags" meta)
|
||
return $ listToMaybe
|
||
[ p | t <- ts
|
||
, let p = takeWhile (/= '/') t
|
||
, p `elem` knownPortals ]
|
||
|
||
-- Per-section item context: kind badge, ISO date for datetime
|
||
-- attr, human-readable display date via essayCtx's dateDisplayField,
|
||
-- abstract via siteCtx's abstractField, and cross-portal filings
|
||
-- in the footer. Suppression is top-segment-based (hide every
|
||
-- tag under the section's portal, not just the exact match) so
|
||
-- a Research-section card doesn't re-list its research/* filings
|
||
-- alongside the section heading. @full-abstract@ unclamps the
|
||
-- card's 2-line abstract truncation — Library is the canonical
|
||
-- browsing surface and shows full abstracts.
|
||
portalItemCtx p =
|
||
contentKindField
|
||
<> tagLinksFieldExcludingTopSegment "item-tags" p
|
||
<> constField "full-abstract" "true"
|
||
<> essayCtx
|
||
|
||
-- Load every content item once, then partition by primary portal
|
||
-- so each shelf draws from a pre-filtered list rather than
|
||
-- re-scanning the whole corpus eight times.
|
||
essays <- loadAll (allEssays .&&. hasNoVersion)
|
||
posts <- loadAll ("content/blog/*.md" .&&. hasNoVersion)
|
||
fiction <- loadAll ("content/fiction/*.md" .&&. hasNoVersion)
|
||
poetry <- loadAll (allPoetry .&&. hasNoVersion)
|
||
music <- loadAll ("content/music/*/index.md" .&&. hasNoVersion)
|
||
let allContent = essays ++ posts ++ fiction ++ poetry ++ music
|
||
:: [Item String]
|
||
tagged <- mapM (\i -> (,i) <$> primaryPortalOf i) allContent
|
||
let itemsByPortal :: Map.Map String [Item String]
|
||
itemsByPortal =
|
||
Map.fromListWith (++) [(p, [i]) | (Just p, i) <- tagged]
|
||
|
||
-- Eager snapshot load registers the library-intro dependency
|
||
-- unconditionally, so a first-populate of content/library.md
|
||
-- re-renders the library page even when the gate was previously
|
||
-- false (see 'sidecarContext' in Tags.hs for the same pattern).
|
||
_ <- loadSnapshot libraryIntroId "body" :: Compiler (Item String)
|
||
let libraryIntroFld = field "library-intro" $ \_ -> do
|
||
html <- itemBody <$> loadSnapshot libraryIntroId "body"
|
||
if all isSpace html
|
||
then noResult "empty library intro"
|
||
else return html
|
||
|
||
-- One shelf's context contribution: the @<slug>-entries@
|
||
-- listField (or absent via noResult when the shelf is
|
||
-- empty) plus an optional @<slug>-has-more@ gate.
|
||
portalSection p = do
|
||
let portalItems = fromMaybe [] (Map.lookup p itemsByPortal)
|
||
sorted <- recentFirstByDisplay portalItems
|
||
|
||
featuredPaths <-
|
||
if sidecarIdentifier p `Set.member` sidecarSet
|
||
then do
|
||
meta <- getMetadata (sidecarIdentifier p)
|
||
return (fromMaybe [] (lookupStringList "featured" meta))
|
||
else return []
|
||
|
||
let portalIdSet =
|
||
Set.fromList (map itemIdentifier portalItems)
|
||
featuredItems =
|
||
[ i
|
||
| path <- featuredPaths
|
||
, let ident = fromFilePath path
|
||
, ident `Set.member` portalIdSet
|
||
, Just i <- [listToMaybe
|
||
(filter ((== ident) . itemIdentifier) portalItems)]
|
||
]
|
||
cap = min libraryShelfMax
|
||
(max libraryShelfCap (length featuredItems))
|
||
featuredIds =
|
||
Set.fromList (map itemIdentifier featuredItems)
|
||
rest = filter (\i -> not (itemIdentifier i `Set.member` featuredIds)) sorted
|
||
merged = take cap (featuredItems ++ rest)
|
||
|
||
let entriesFld =
|
||
listField (p ++ "-entries") (portalItemCtx p)
|
||
(if null merged
|
||
then noResult ("no items in portal " ++ p)
|
||
else return merged)
|
||
hasMoreFld
|
||
| length portalItems > length merged =
|
||
constField (p ++ "-has-more") "true"
|
||
| otherwise = mempty
|
||
|
||
return (entriesFld <> hasMoreFld)
|
||
|
||
-- Section order follows homePortals — single ordering authority.
|
||
sections <- mapM portalSection knownPortals
|
||
|
||
let ctx = mconcat sections
|
||
<> libraryIntroFld
|
||
<> constField "title" "Library"
|
||
<> constField "library" "true"
|
||
<> siteCtx
|
||
|
||
makeItem ""
|
||
>>= loadAndApplyTemplate "templates/library.html" ctx
|
||
>>= loadAndApplyTemplate "templates/default.html" ctx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Bibliography — synthetic index + per-keyword pages (Phase 6b).
|
||
-- ---------------------------------------------------------------------------
|
||
-- Bibliography-meta sidecars: same shape as tag-meta, used by the
|
||
-- per-keyword pages for the prose intro and (future) tooltips. No
|
||
-- route; body snapshot consumed by the keyword rule.
|
||
match ("content/bibliography-meta/*.md" .||. "content/bibliography-meta/**/*.md") $
|
||
compile sidecarCompiler
|
||
|
||
-- Collect the universe of keywords at rule-gen time. Two sources:
|
||
-- * @keywords:@ fields across all @data/*.bib@ entries
|
||
-- * @keywords:@ frontmatter across all essays + blog + poetry +
|
||
-- fiction + music-composition pages
|
||
-- The union drives which @/bibliography/\<kw\>/@ pages get generated;
|
||
-- keywords with no referents anywhere are not synthesized into pages.
|
||
bibFilePaths <- preprocess $ do
|
||
files <- listDirectory "data"
|
||
return $ sort [ "data" </> f | f <- files, takeExtension f == ".bib" ]
|
||
|
||
bibExtrasAll <- preprocess $
|
||
Map.unions <$> mapM parseBibExtras bibFilePaths
|
||
|
||
let bibKwMap :: Map String [String]
|
||
bibKwMap = invertKeywordsBib bibExtrasAll
|
||
|
||
writingIds <- getMatches $ (P.essayPattern
|
||
.||. "content/blog/*.md"
|
||
.||. "content/fiction/*.md"
|
||
.||. P.poetryPattern
|
||
.||. "content/music/*/index.md")
|
||
.&&. hasNoVersion
|
||
|
||
writingKwPairs <- forM writingIds $ \ident -> do
|
||
meta <- getMetadata ident
|
||
let kws = readKeywords meta
|
||
return (ident, kws)
|
||
|
||
let writingKwMap :: Map String [Identifier]
|
||
writingKwMap = invertKeywordsWritings writingKwPairs
|
||
|
||
-- Keywords with at least one referent (writing OR bib entry).
|
||
allKeywords :: Set String
|
||
allKeywords = Set.union (Map.keysSet bibKwMap) (Map.keysSet writingKwMap)
|
||
|
||
-- Identifiers of bibliography-meta sidecars that exist on disk,
|
||
-- used to optionally inject $portal-intro$ + $portal-tooltip$ on
|
||
-- keyword pages when the author populates a sidecar.
|
||
bibMetaIds <- getMatches ("content/bibliography-meta/*.md"
|
||
.||. "content/bibliography-meta/**/*.md")
|
||
let bibMetaSet = Set.fromList bibMetaIds
|
||
|
||
-- /bibliography/index.html — every entry across every .bib file.
|
||
-- Sort: ascending by first-author surname, year-descending within
|
||
-- author (scholarly convention).
|
||
create ["bibliography/index.html"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
let sortedKeys = bibliographyIndexOrder bibExtrasAll
|
||
grouped = groupByLetter bibExtrasAll sortedKeys
|
||
present = map fst grouped
|
||
html <- unsafeCompiler $ do
|
||
parts <- forM grouped $ \(letter, keys) -> do
|
||
body <- renderBibliographyHtml bibFilePaths bibExtrasAll keys
|
||
return (renderLetterHeader letter <> body)
|
||
return (renderBibliographyAlphabet present <> T.concat parts)
|
||
let ctx = constField "title" "Bibliography"
|
||
<> constField "bibliography-index" "true"
|
||
<> constField "bibliography-entries" (T.unpack html)
|
||
<> constField "library" "true" -- reuse flag to load library.css + item-card.css
|
||
<> siteCtx
|
||
makeItem ""
|
||
>>= loadAndApplyTemplate "templates/bibliography-index.html" ctx
|
||
>>= loadAndApplyTemplate "templates/default.html" ctx
|
||
>>= relativizeUrls
|
||
|
||
-- /bibliography/<keyword>/index.html for each keyword in the union.
|
||
forM_ (Set.toList allKeywords) $ \kw ->
|
||
create [fromFilePath ("bibliography/" ++ kw ++ "/index.html")] $ do
|
||
route idRoute
|
||
compile $ do
|
||
-- Writings section
|
||
let wIds = fromMaybe [] (Map.lookup kw writingKwMap)
|
||
writingItems <- case wIds of
|
||
[] -> return []
|
||
_ -> recentFirstByDisplay
|
||
=<< mapM (\i -> load i :: Compiler (Item String)) wIds
|
||
let writingsCtx
|
||
| null writingItems = mempty
|
||
| otherwise = listField "writings" (portalWritingCtx kw)
|
||
(return writingItems)
|
||
<> constField "has-writings" "true"
|
||
|
||
-- References section
|
||
let refKeys = keywordReferencesOrder bibExtrasAll kw
|
||
refsHtml <- unsafeCompiler $
|
||
renderBibliographyHtml bibFilePaths bibExtrasAll refKeys
|
||
let referencesCtx
|
||
| null refKeys = mempty
|
||
| otherwise =
|
||
constField "references" (T.unpack refsHtml)
|
||
|
||
-- Sidecar (tooltip + optional prose intro)
|
||
let sidecarId = bibliographyMetaIdentifier kw
|
||
hasSidecar = sidecarId `Set.member` bibMetaSet
|
||
scCtx <- if hasSidecar
|
||
then do
|
||
_ <- loadSnapshot sidecarId "body" :: Compiler (Item String)
|
||
return (portalIntroField (const sidecarId)
|
||
<> portalTooltipField (const sidecarId))
|
||
else return mempty
|
||
|
||
let ctx = constField "title" kw
|
||
<> constField "keyword" kw
|
||
<> constField "bibliography-keyword" "true"
|
||
<> constField "library" "true" -- reuse flag to load library.css + item-card.css
|
||
<> writingsCtx
|
||
<> referencesCtx
|
||
<> scCtx
|
||
<> siteCtx
|
||
makeItem ""
|
||
>>= loadAndApplyTemplate "templates/bibliography-keyword.html" ctx
|
||
>>= loadAndApplyTemplate "templates/default.html" ctx
|
||
>>= relativizeUrls
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Random page manifest — essays + blog posts only (no pagination/index pages)
|
||
-- ---------------------------------------------------------------------------
|
||
create ["random-pages.json"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
essays <- loadAll (allEssays .&&. hasNoVersion) :: Compiler [Item String]
|
||
posts <- loadAll ("content/blog/*.md" .&&. hasNoVersion) :: Compiler [Item String]
|
||
fiction <- loadAll ("content/fiction/*.md" .&&. hasNoVersion) :: Compiler [Item String]
|
||
poetry <- loadAll ("content/poetry/*.md" .&&. hasNoVersion) :: Compiler [Item String]
|
||
routes <- mapM (getRoute . itemIdentifier) (essays ++ posts ++ fiction ++ poetry)
|
||
let urls = [ "/" ++ r | Just r <- routes ]
|
||
makeItem $ LBS.unpack (Aeson.encode urls)
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Epistemic metadata manifest — maps page URLs to epistemic fields
|
||
-- (status, confidence, importance, evidence, scope, novelty, practicality,
|
||
-- stability, score) for client-side search filtering.
|
||
-- ---------------------------------------------------------------------------
|
||
create ["data/epistemic-meta.json"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
essays <- loadAll (allEssays .&&. hasNoVersion) :: Compiler [Item String]
|
||
posts <- loadAll ("content/blog/*.md" .&&. hasNoVersion) :: Compiler [Item String]
|
||
fiction <- loadAll ("content/fiction/*.md" .&&. hasNoVersion) :: Compiler [Item String]
|
||
poetry <- loadAll (allPoetry .&&. hasNoVersion) :: Compiler [Item String]
|
||
music <- loadAll ("content/music/*/index.md" .&&. hasNoVersion) :: Compiler [Item String]
|
||
let items = essays ++ posts ++ fiction ++ poetry ++ music
|
||
pairs <- mapM epistemicEntry items
|
||
let metaMap = Map.fromList (catMaybes pairs)
|
||
makeItem $ LBS.unpack (Aeson.encode metaMap)
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Atom feed — all content sorted by date
|
||
-- ---------------------------------------------------------------------------
|
||
create ["feed.xml"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
posts <- fmap (take 30) . recentFirst
|
||
=<< loadAllSnapshots
|
||
( ( allEssays
|
||
.||. "content/blog/*.md"
|
||
.||. "content/fiction/*.md"
|
||
.||. allPoetry
|
||
.||. "content/music/*/index.md"
|
||
)
|
||
.&&. hasNoVersion
|
||
)
|
||
"content"
|
||
let feedCtx =
|
||
dateField "updated" "%Y-%m-%dT%H:%M:%SZ"
|
||
<> dateField "published" "%Y-%m-%dT%H:%M:%SZ"
|
||
<> bodyField "description"
|
||
<> defaultContext
|
||
renderAtom feedConfig feedCtx posts
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Music feed — compositions only
|
||
-- ---------------------------------------------------------------------------
|
||
create ["music/feed.xml"] $ do
|
||
route idRoute
|
||
compile $ do
|
||
compositions <- recentFirst
|
||
=<< loadAllSnapshots
|
||
("content/music/*/index.md" .&&. hasNoVersion)
|
||
"content"
|
||
let feedCtx =
|
||
dateField "updated" "%Y-%m-%dT%H:%M:%SZ"
|
||
<> dateField "published" "%Y-%m-%dT%H:%M:%SZ"
|
||
<> bodyField "description"
|
||
<> defaultContext
|
||
renderAtom musicFeedConfig feedCtx compositions
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Epistemic metadata extraction
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Extract epistemic metadata from a content item's frontmatter.
|
||
-- Returns Nothing if the item has no route or no epistemic fields.
|
||
epistemicEntry :: Item String -> Compiler (Maybe (String, Map.Map String String))
|
||
epistemicEntry item = do
|
||
let ident = itemIdentifier item
|
||
mRoute <- getRoute ident
|
||
case mRoute of
|
||
Nothing -> return Nothing
|
||
Just r -> do
|
||
meta <- getMetadata ident
|
||
let url = "/" ++ r
|
||
fields = catMaybes
|
||
[ grab "status" meta
|
||
, grab "confidence" meta
|
||
, grab "importance" meta
|
||
, grab "evidence" meta
|
||
, grab "scope" meta
|
||
, grab "novelty" meta
|
||
, grab "practicality" meta
|
||
, grab "stability" meta
|
||
]
|
||
obj = Map.fromList fields
|
||
-- Compute overall-score the same way Contexts.overallScoreField does.
|
||
obj' = case ( readMaybe =<< lookupString "confidence" meta :: Maybe Int
|
||
, readMaybe =<< lookupString "evidence" meta :: Maybe Int
|
||
) of
|
||
(Just conf, Just ev) ->
|
||
let raw :: Double
|
||
raw = fromIntegral conf / 100.0 * 0.6
|
||
+ fromIntegral (ev - 1) / 4.0 * 0.4
|
||
score = max 0 (min 100 (round (raw * 100.0) :: Int))
|
||
in Map.insert "score" (show score) obj
|
||
_ -> obj
|
||
if Map.null obj'
|
||
then return Nothing
|
||
else return (Just (url, obj'))
|
||
where
|
||
grab name meta = case lookupString name meta of
|
||
Just v -> Just (name, v)
|
||
Nothing -> Nothing
|
||
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Bibliography helpers (Phase 6b)
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Invert a @citekey -> BibExtra@ map into @keyword -> [citekey]@
|
||
-- using each entry's 'bibKeywords' list as the inversion source.
|
||
invertKeywordsBib :: Map String BibExtra -> Map String [String]
|
||
invertKeywordsBib =
|
||
Map.fromListWith (++) . concatMap flatten . Map.toList
|
||
where
|
||
flatten (k, e) = [ (kw, [k]) | kw <- bibKeywords e ]
|
||
|
||
-- | Read a @keywords:@ frontmatter field, accepting YAML list and
|
||
-- comma-separated scalar forms. Matches 'Contexts.keywordLinksField'.
|
||
readKeywords :: Metadata -> [String]
|
||
readKeywords meta = filter (not . null) . map trimSpaces $
|
||
case lookupStringList "keywords" meta of
|
||
Just xs -> xs
|
||
Nothing -> case lookupString "keywords" meta of
|
||
Just s -> splitComma s
|
||
Nothing -> []
|
||
where
|
||
trimSpaces = dropWhile (== ' ') . reverse . dropWhile (== ' ') . reverse
|
||
splitComma s = case break (== ',') s of
|
||
(before, []) -> [before]
|
||
(before, _ : rest) -> before : splitComma rest
|
||
|
||
-- | Invert a @[(Identifier, [keyword])]@ association into
|
||
-- @keyword -> [Identifier]@. Identifiers can appear under multiple
|
||
-- keywords (multi-keyword items).
|
||
invertKeywordsWritings :: [(Identifier, [String])] -> Map String [Identifier]
|
||
invertKeywordsWritings pairs =
|
||
Map.fromListWith (++)
|
||
[ (kw, [ident]) | (ident, kws) <- pairs, kw <- kws ]
|
||
|
||
-- | Sort citekeys for the /bibliography/ index: ascending first-author
|
||
-- surname, year-descending within author.
|
||
bibliographyIndexOrder :: Map String BibExtra -> [String]
|
||
bibliographyIndexOrder extras =
|
||
map fst $ sortBy (comparing sortKey) (Map.toList extras)
|
||
where
|
||
sortKey (_, e) = (firstAuthorSurname e, Down (bibYear e))
|
||
|
||
-- | Sort citekeys for a /bibliography/<kw>/ References section: year
|
||
-- descending, then alphabetical by first-author surname within the
|
||
-- year. Filtered to only entries whose 'bibKeywords' includes @kw@.
|
||
keywordReferencesOrder :: Map String BibExtra -> String -> [String]
|
||
keywordReferencesOrder extras kw =
|
||
map fst $ sortBy (comparing sortKey)
|
||
[ (k, e) | (k, e) <- Map.toList extras, kw `elem` bibKeywords e ]
|
||
where
|
||
sortKey (_, e) = (Down (bibYear e), firstAuthorSurname e)
|
||
|
||
-- | Identifier of a bibliography-meta sidecar for a given keyword.
|
||
-- Parallels 'Tags.sidecarIdentifier' but under
|
||
-- @content/bibliography-meta/@ rather than @content/tag-meta/@.
|
||
bibliographyMetaIdentifier :: String -> Identifier
|
||
bibliographyMetaIdentifier kw =
|
||
fromFilePath ("content/bibliography-meta/" ++ kw ++ ".md")
|
||
|
||
-- | Group an alphabetically-sorted list of citekeys into letter buckets
|
||
-- keyed by the uppercase first letter of each entry's first-author
|
||
-- surname (falling back to the citekey's first letter when no author
|
||
-- was parsed — edge case, shouldn't occur in current content).
|
||
--
|
||
-- Because @sortedKeys@ is already alphabetical, 'Data.List.groupBy'
|
||
-- produces contiguous same-letter runs in one pass.
|
||
groupByLetter :: Map String BibExtra -> [String] -> [(Char, [String])]
|
||
groupByLetter extras sortedKeys =
|
||
let withLetters = [ (k, letterOf k) | k <- sortedKeys ]
|
||
grouped = groupBy (\(_, a) (_, b) -> a == b) withLetters
|
||
in [ (letter, map fst grp) | grp <- grouped
|
||
, (_, letter) : _ <- [grp] ]
|
||
where
|
||
letterOf k =
|
||
let e = fromMaybe emptyBibExtra (Map.lookup k extras)
|
||
in case firstAuthorSurname e of
|
||
(c:_) -> toUpper c
|
||
_ -> case k of
|
||
(c:_) -> toUpper c
|
||
_ -> '?'
|
||
|
||
-- | The A–Z jump strip above the entry list. Present letters render as
|
||
-- anchor links to their section heading; absent letters render as
|
||
-- muted, non-linked spans so the alphabet reads as a complete strip
|
||
-- regardless of content gaps.
|
||
renderBibliographyAlphabet :: [Char] -> T.Text
|
||
renderBibliographyAlphabet presentList =
|
||
let present = Set.fromList presentList
|
||
cell c
|
||
| c `Set.member` present =
|
||
"<a href=\"#" <> T.singleton c
|
||
<> "\" class=\"alpha\">" <> T.singleton c <> "</a>"
|
||
| otherwise =
|
||
"<span class=\"alpha alpha-empty\" aria-hidden=\"true\">"
|
||
<> T.singleton c <> "</span>"
|
||
in "<nav class=\"bibliography-alphabet\" aria-label=\"Jump to letter\">"
|
||
<> T.concat (map cell ['A' .. 'Z'])
|
||
<> "</nav>\n"
|
||
|
||
-- | Letter-group heading inserted between entry groups on the
|
||
-- bibliography index. The @id@ is the anchor target for
|
||
-- 'renderBibliographyAlphabet' jump-links.
|
||
renderLetterHeader :: Char -> T.Text
|
||
renderLetterHeader c =
|
||
"<h2 id=\"" <> T.singleton c
|
||
<> "\" class=\"bibliography-letter\">"
|
||
<> T.singleton c <> "</h2>\n"
|
||
|
||
-- | Item-level context for Writings-section cards on a keyword page.
|
||
-- Same fields as the library's 'portalItemCtx' but with tag-footer
|
||
-- suppression tuned to the keyword context rather than a portal
|
||
-- (nothing to suppress here — writings keep their full tag list so
|
||
-- readers can see the item's own portal filings).
|
||
portalWritingCtx :: String -> Context String
|
||
portalWritingCtx _kw =
|
||
contentKindField
|
||
<> constField "full-abstract" "true"
|
||
<> essayCtx
|