levineuwirth.org/build/Site.hs

982 lines
47 KiB
Haskell
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{-# 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 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
-- ---------------------------------------------------------------------------
-- 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
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/library.md") $ do
route $ gsubRoute "content/" (const "")
`composeRoutes` setExtension "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 AZ 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