889 lines
39 KiB
Haskell
889 lines
39 KiB
Haskell
{-# LANGUAGE GHC2021 #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
module Contexts
|
||
( siteCtx
|
||
, essayCtx
|
||
, postCtx
|
||
, pageCtx
|
||
, poetryCtx
|
||
, fictionCtx
|
||
, compositionCtx
|
||
, contentKindField
|
||
, abstractField
|
||
, descriptionField
|
||
, tagLinksField
|
||
, tagLinksFieldExcludingScope
|
||
, tagLinksFieldExcludingTopSegment
|
||
, keywordLinksField
|
||
, authorLinksField
|
||
, dateDisplayField
|
||
, revisionDateFields
|
||
, recentFirstByDisplay
|
||
, Revision (..)
|
||
, getRevisions
|
||
) where
|
||
|
||
import Data.Aeson (Value (..))
|
||
import qualified Data.Aeson.KeyMap as KM
|
||
import qualified Data.Vector as V
|
||
import Data.List (intercalate, isPrefixOf, sortBy)
|
||
import Data.Maybe (fromMaybe, mapMaybe)
|
||
import Data.Ord (comparing)
|
||
import Data.Time.Calendar (toGregorian)
|
||
import Data.Time.Clock (UTCTime, getCurrentTime, utctDay)
|
||
import Data.Time.Format (formatTime, defaultTimeLocale, parseTimeM)
|
||
import System.FilePath (takeDirectory, takeFileName)
|
||
import Text.Read (readMaybe)
|
||
import qualified Data.Text as T
|
||
import Text.Pandoc (runPure, readMarkdown, writeHtml5String, writePlain, Pandoc(..), Block(..), Inline(..))
|
||
import Text.Pandoc.Options (WriterOptions(..), HTMLMathMethod(..))
|
||
import Hakyll hiding (trim)
|
||
import Backlinks (backlinksField)
|
||
import Dingbat (dingbatField)
|
||
import SimilarLinks (similarLinksField)
|
||
import Stability (stabilityField, lastReviewedField, lastReviewedIsoField,
|
||
versionHistoryField,
|
||
versionHistoryPrimaryField, versionHistoryRestField,
|
||
versionHistoryRangeField, versionHistoryRangeStartField,
|
||
versionHistoryRangeEndField, versionHistoryCommitsField)
|
||
import Utils (authorSlugify, authorNameOf, trim)
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Affiliation field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Parses the @affiliation@ frontmatter key and exposes each entry as
|
||
-- @affiliation-name@ / @affiliation-url@ pairs.
|
||
--
|
||
-- Accepts a scalar string or a YAML list. Each entry may use pipe syntax:
|
||
-- @"Brown University | https://cs.brown.edu"@
|
||
-- Entries without a URL still produce a row; @affiliation-url@ fails
|
||
-- (evaluates to noResult), so @$if(affiliation-url)$@ works in templates.
|
||
--
|
||
-- Usage:
|
||
-- $for(affiliation-links)$
|
||
-- $if(affiliation-url)$<a href="$affiliation-url$">$affiliation-name$</a>
|
||
-- $else$$affiliation-name$$endif$$sep$ · $endfor$
|
||
affiliationField :: Context a
|
||
affiliationField = listFieldWith "affiliation-links" ctx $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let entries = case lookupStringList "affiliation" meta of
|
||
Just xs -> xs
|
||
Nothing -> maybe [] (:[]) (lookupString "affiliation" meta)
|
||
return $ map (Item (fromFilePath "") . parseEntry) entries
|
||
where
|
||
ctx = field "affiliation-name" (return . fst . itemBody)
|
||
<> field "affiliation-url" (\i -> let u = snd (itemBody i)
|
||
in if null u then noResult "no url" else return u)
|
||
parseEntry s = case break (== '|') s of
|
||
(name, '|' : url) -> (trim name, trim url)
|
||
(name, _) -> (trim name, "")
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Build time field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Resolves to the time the current item was compiled, formatted as
|
||
-- "Saturday, November 15th, 2025 15:05:55" (UTC).
|
||
buildTimeField :: Context String
|
||
buildTimeField = field "build-time" $ \_ ->
|
||
unsafeCompiler $ do
|
||
t <- getCurrentTime
|
||
let (_, _, d) = toGregorian (utctDay t)
|
||
prefix = formatTime defaultTimeLocale "%A, %B " t
|
||
suffix = formatTime defaultTimeLocale ", %Y %H:%M:%S" t
|
||
return (prefix ++ show d ++ ordSuffix d ++ suffix)
|
||
where
|
||
ordSuffix n
|
||
| n `elem` [11,12,13] = "th"
|
||
| n `mod` 10 == 1 = "st"
|
||
| n `mod` 10 == 2 = "nd"
|
||
| n `mod` 10 == 3 = "rd"
|
||
| otherwise = "th"
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Content kind field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | @$item-kind$@: human-readable content type derived from the item's route.
|
||
-- Used on the New page to label each entry (Essay, Post, Poem, etc.).
|
||
contentKindField :: Context String
|
||
contentKindField = field "item-kind" $ \item -> do
|
||
r <- getRoute (itemIdentifier item)
|
||
return $ case r of
|
||
Nothing -> "Page"
|
||
Just r'
|
||
| "essays/" `isPrefixOf` r' -> "Essay"
|
||
| "blog/" `isPrefixOf` r' -> "Post"
|
||
| "poetry/" `isPrefixOf` r' -> "Poem"
|
||
| "fiction/" `isPrefixOf` r' -> "Fiction"
|
||
| "music/" `isPrefixOf` r' -> "Composition"
|
||
| otherwise -> "Page"
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Site-wide context
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | @$page-scripts$@ — list field providing @$script-src$@ for each entry
|
||
-- in the @js:@ frontmatter key (accepts a scalar string or a YAML list).
|
||
-- Returns an empty list when absent; $for iterates zero times, emitting nothing.
|
||
-- NOTE: do not use fail here — $for does not catch noResult the way $if does.
|
||
--
|
||
-- Each child Item is keyed on @<parent-identifier>#js-<index>@ so that two
|
||
-- pages referencing the same script path (e.g. @shared.js@) do not collide
|
||
-- in Hakyll's item store.
|
||
pageScriptsField :: Context String
|
||
pageScriptsField = listFieldWith "page-scripts" ctx $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let scripts = case lookupStringList "js" meta of
|
||
Just xs -> xs
|
||
Nothing -> maybe [] (:[]) (lookupString "js" meta)
|
||
parent = toFilePath (itemIdentifier item)
|
||
return $ zipWith
|
||
(\i s -> Item (fromFilePath (parent ++ "#js-" ++ show (i :: Int))) s)
|
||
[0 ..]
|
||
scripts
|
||
where
|
||
ctx = field "script-src" (return . itemBody)
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Tag links field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | List context field exposing an item's own (non-expanded) tags as
|
||
-- @tag-name@ / @tag-url@ objects.
|
||
--
|
||
-- $for(essay-tags)$<a href="$tag-url$">$tag-name$</a>$endfor$
|
||
tagLinksField :: String -> Context a
|
||
tagLinksField fieldName = listFieldWith fieldName ctx $ \item ->
|
||
map toItem <$> getTags (itemIdentifier item)
|
||
where
|
||
toItem t = Item (fromFilePath (t ++ "/index.html")) t
|
||
ctx = field "tag-name" (return . itemBody)
|
||
<> field "tag-url" (\i -> return $ "/" ++ itemBody i ++ "/")
|
||
|
||
-- | Variant of 'tagLinksField' that suppresses tags equal to or ancestral
|
||
-- to the given scope. Used on tag index pages to hide the redundant
|
||
-- filing ribbon entry for the current page's own scope.
|
||
--
|
||
-- Suppression is equality-based on the scope plus its prefix-ancestors:
|
||
-- on @\/nonfiction\/@ (scope = @"nonfiction"@) only the literal
|
||
-- @"nonfiction"@ tag is hidden; @"nonfiction/philosophy"@ still renders.
|
||
-- On @\/nonfiction\/philosophy\/@ both @"nonfiction"@ and
|
||
-- @"nonfiction/philosophy"@ are hidden; sibling and cross-filed tags
|
||
-- remain.
|
||
--
|
||
-- When every tag is suppressed, the field fails with 'noResult' so
|
||
-- @$if(...)$@ is false and the tag-ribbon wrapper is omitted entirely
|
||
-- instead of rendering as an empty @<div>@.
|
||
tagLinksFieldExcludingScope :: String -> String -> Context a
|
||
tagLinksFieldExcludingScope fieldName scope =
|
||
listFieldWith fieldName ctx $ \item -> do
|
||
ts <- getTags (itemIdentifier item)
|
||
let visible = filter (not . isScopeOrAncestor) ts
|
||
if null visible
|
||
then noResult "no visible tags after scope suppression"
|
||
else return (map toItem visible)
|
||
where
|
||
toItem t = Item (fromFilePath (t ++ "/index.html")) t
|
||
ctx = field "tag-name" (return . itemBody)
|
||
<> field "tag-url" (\i -> return $ "/" ++ itemBody i ++ "/")
|
||
-- Hide tag t when t == scope, or when t is a strict prefix-ancestor
|
||
-- of scope (i.e., scope starts with t ++ "/"). Descendants of scope
|
||
-- (e.g., "nonfiction/philosophy" when scope="nonfiction") are kept.
|
||
isScopeOrAncestor t = t == scope || (t ++ "/") `isPrefixOf` scope
|
||
|
||
-- | Variant of 'tagLinksField' that suppresses any tag whose top
|
||
-- (slash-separated) segment equals the given scope. Used by the
|
||
-- Library page: an item rendered under the "Research" section
|
||
-- should not re-list its own @research\/*@ filings in the tag
|
||
-- footer (the section heading makes those structurally implied),
|
||
-- but should still list @tech\/*@ cross-filings.
|
||
--
|
||
-- This is distinct from 'tagLinksFieldExcludingScope', which
|
||
-- suppresses only exact-match and strict ancestors. Library's
|
||
-- redundancy goal is broader: hide the whole subtree rooted at
|
||
-- the section's portal, not just the portal tag itself.
|
||
--
|
||
-- @
|
||
-- scope = "research"
|
||
-- t = "research" → hide (top = "research" == scope)
|
||
-- t = "research/cryptography" → hide (top = "research" == scope)
|
||
-- t = "tech" → show (top = "tech" /= scope)
|
||
-- t = "tech/hpc" → show (top = "tech" /= scope)
|
||
-- @
|
||
--
|
||
-- 'noResult' fires when every tag is suppressed so
|
||
-- @$if(item-tags)$@ gates off an empty footer wrapper, same
|
||
-- discipline as 'tagLinksFieldExcludingScope'.
|
||
tagLinksFieldExcludingTopSegment :: String -> String -> Context a
|
||
tagLinksFieldExcludingTopSegment fieldName scope =
|
||
listFieldWith fieldName ctx $ \item -> do
|
||
ts <- getTags (itemIdentifier item)
|
||
let visible = filter (not . matchesTopSegment) ts
|
||
if null visible
|
||
then noResult "no cross-portal tags after top-segment suppression"
|
||
else return (map toItem visible)
|
||
where
|
||
toItem t = Item (fromFilePath (t ++ "/index.html")) t
|
||
ctx = field "tag-name" (return . itemBody)
|
||
<> field "tag-url" (\i -> return $ "/" ++ itemBody i ++ "/")
|
||
matchesTopSegment t = takeWhile (/= '/') t == scope
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Keyword links field (bibliography-scoped vocabulary, Phase 6a)
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | List context field exposing an item's @keywords:@ frontmatter as
|
||
-- @$kw-name$@ / @$kw-url$@ pairs. URL targets @/bibliography/\<kw\>/@,
|
||
-- the per-keyword bibliography pages (built by Phase 6b; links will
|
||
-- 404 until then, deliberately — the mechanism has to be in place
|
||
-- before the pages can be populated).
|
||
--
|
||
-- Shared vocabulary with bib-entry @keywords:@ fields parsed by
|
||
-- 'BibExtras.parseBibExtras'. An essay tagged with the same keyword
|
||
-- as a bib entry will appear alongside that entry on the keyword
|
||
-- page.
|
||
--
|
||
-- Accepts both YAML list and comma-separated scalar forms:
|
||
--
|
||
-- @
|
||
-- keywords: [crypto, lattices]
|
||
-- keywords:
|
||
-- - crypto
|
||
-- - lattices
|
||
-- keywords: "crypto, lattices"
|
||
-- @
|
||
--
|
||
-- Returns @noResult@ when absent or empty so the template's
|
||
-- @$if(essay-keywords)$@ gate suppresses the meta row.
|
||
--
|
||
-- Usage in metadata.html:
|
||
--
|
||
-- @
|
||
-- $for(essay-keywords)$\<a class="meta-keyword" href="$kw-url$"\>$kw-name$\</a\>$endfor$
|
||
-- @
|
||
keywordLinksField :: String -> Context a
|
||
keywordLinksField fieldName = listFieldWith fieldName ctx $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let kws = case lookupStringList "keywords" meta of
|
||
Just xs -> xs
|
||
Nothing -> case lookupString "keywords" meta of
|
||
Just s -> filter (not . null) (map trim (splitOn ',' s))
|
||
Nothing -> []
|
||
visible = filter (not . null . trim) kws
|
||
if null visible
|
||
then noResult "no keywords"
|
||
else return (map toItem visible)
|
||
where
|
||
toItem k = Item (fromFilePath (k ++ "/index.html")) k
|
||
ctx = field "kw-name" (return . itemBody)
|
||
<> field "kw-url" (\i -> return $ "/bibliography/" ++ itemBody i ++ "/")
|
||
|
||
splitOn :: Char -> String -> [String]
|
||
splitOn c s = case break (== c) s of
|
||
(before, []) -> [before]
|
||
(before, _ : rest) -> before : splitOn c rest
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Author links field
|
||
-- ---------------------------------------------------------------------------
|
||
--
|
||
-- 'authorSlugify' and 'authorNameOf' are imported from 'Utils' so that
|
||
-- they cannot drift from the copies in 'Authors'.
|
||
|
||
-- | Exposes each item's authors as @author-name@ / @author-url@ pairs.
|
||
-- Defaults to Levi Neuwirth when no "authors" frontmatter key is present.
|
||
--
|
||
-- Entries that produce an empty name (e.g. @"| https://url"@) or an empty
|
||
-- slug (e.g. all-punctuation names) are dropped, so the field never emits
|
||
-- a @/authors//@ link.
|
||
--
|
||
-- $for(author-links)$<a href="$author-url$">$author-name$</a>$sep$, $endfor$
|
||
authorLinksField :: Context a
|
||
authorLinksField = listFieldWith "author-links" ctx $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let entries = fromMaybe [] (lookupStringList "authors" meta)
|
||
rawNames = if null entries then ["Levi Neuwirth"] else map authorNameOf entries
|
||
validNames = filter (\n -> not (null n) && not (null (authorSlugify n))) rawNames
|
||
names = if null validNames then ["Levi Neuwirth"] else validNames
|
||
return $ map (\n -> Item (fromFilePath "") (n, "/authors/" ++ authorSlugify n ++ "/")) names
|
||
where
|
||
ctx = field "author-name" (return . fst . itemBody)
|
||
<> field "author-url" (return . snd . itemBody)
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Abstract field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Renders the abstract using Pandoc to support Markdown and LaTeX math.
|
||
-- Strips the outer @<p>@ wrapping. A single-paragraph abstract becomes a
|
||
-- bare @Plain@ so the rendered HTML is unwrapped inlines. A multi-paragraph
|
||
-- abstract (author used a blank line in the YAML literal block) is flattened
|
||
-- to a single @Plain@ with @LineBreak@ separators between what were
|
||
-- originally paragraph boundaries — the visual break is preserved without
|
||
-- emitting stray @<p>@ tags inside the metadata block. Mixed block content
|
||
-- (e.g. an abstract containing a blockquote) falls through unchanged.
|
||
abstractField :: Context String
|
||
abstractField = field "abstract" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case lookupString "abstract" meta of
|
||
Nothing -> fail "no abstract"
|
||
Just src -> do
|
||
let pandocResult = runPure $ do
|
||
doc <- readMarkdown defaultHakyllReaderOptions (T.pack src)
|
||
let doc' = case doc of
|
||
Pandoc m [Para ils] -> Pandoc m [Plain ils]
|
||
Pandoc m blocks
|
||
| all isPara blocks && not (null blocks) ->
|
||
let joined = intercalate [LineBreak]
|
||
[ils | Para ils <- blocks]
|
||
in Pandoc m [Plain joined]
|
||
_ -> doc
|
||
let wOpts = defaultHakyllWriterOptions { writerHTMLMathMethod = MathML }
|
||
writeHtml5String wOpts doc'
|
||
case pandocResult of
|
||
Left err -> fail $ "Pandoc error rendering abstract: " ++ show err
|
||
Right html -> return (T.unpack html)
|
||
where
|
||
isPara (Para _) = True
|
||
isPara _ = False
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Description field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Renders the @abstract@ frontmatter key as plain text suitable for use in
|
||
-- @<meta name="description">@, @og:description@, and @twitter:description@.
|
||
-- Strips Pandoc markup, collapses internal whitespace, truncates to ~200
|
||
-- chars, and HTML-escapes attribute-special characters. Returns @noResult@
|
||
-- when no @abstract@ is present (so @$if(description)$@ short-circuits).
|
||
descriptionField :: Context String
|
||
descriptionField = field "description" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case lookupString "abstract" meta of
|
||
Nothing -> fail "no abstract"
|
||
Just src -> do
|
||
let pandocResult = runPure $ do
|
||
doc <- readMarkdown defaultHakyllReaderOptions (T.pack src)
|
||
writePlain defaultHakyllWriterOptions doc
|
||
case pandocResult of
|
||
Left err -> fail $ "Pandoc error rendering description: " ++ show err
|
||
Right txt ->
|
||
let collapsed = T.unwords (T.words txt)
|
||
capped = if T.length collapsed > 200
|
||
then T.take 197 collapsed <> T.pack "\x2026"
|
||
else collapsed
|
||
in return (attrEscape (T.unpack capped))
|
||
|
||
-- | HTML-escape characters that would break out of an attribute value.
|
||
attrEscape :: String -> String
|
||
attrEscape = concatMap esc
|
||
where
|
||
esc '&' = "&"
|
||
esc '<' = "<"
|
||
esc '>' = ">"
|
||
esc '"' = """
|
||
esc '\'' = "'"
|
||
esc c = [c]
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Summary field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Renders the @summary@ frontmatter key through Pandoc, preserving full
|
||
-- block structure (paragraphs, bold, lists). Unlike 'abstractField', no
|
||
-- paragraph flattening is applied because the summary renders inside its
|
||
-- own styled box rather than inline in the metadata strip.
|
||
summaryField :: Context String
|
||
summaryField = field "summary" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case lookupString "summary" meta of
|
||
Nothing -> fail "no summary"
|
||
Just src -> do
|
||
let pandocResult = runPure $ do
|
||
doc <- readMarkdown defaultHakyllReaderOptions (T.pack src)
|
||
let wOpts = defaultHakyllWriterOptions { writerHTMLMathMethod = MathML }
|
||
writeHtml5String wOpts doc
|
||
case pandocResult of
|
||
Left err -> fail $ "Pandoc error rendering summary: " ++ show err
|
||
Right html -> return (T.unpack html)
|
||
|
||
siteCtx :: Context String
|
||
siteCtx =
|
||
constField "site-title" "Levi Neuwirth"
|
||
<> constField "site-url" "https://levineuwirth.org"
|
||
<> buildTimeField
|
||
<> pageScriptsField
|
||
<> abstractField
|
||
<> descriptionField
|
||
<> summaryField
|
||
<> dingbatField
|
||
<> defaultContext
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Helper: load a named snapshot as a context field
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | @snapshotField name snap@ creates a context field @name@ whose value is
|
||
-- the body of the snapshot @snap@ saved for the current item.
|
||
snapshotField :: String -> Snapshot -> Context String
|
||
snapshotField name snap = field name $ \item ->
|
||
itemBody <$> loadSnapshot (itemIdentifier item) snap
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Essay context
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Bibliography field: loads the citation HTML saved by essayCompiler.
|
||
-- Returns noResult (making $if(bibliography)$ false) when empty.
|
||
-- Also provides $has-citations$ for conditional JS loading.
|
||
bibliographyField :: Context String
|
||
bibliographyField = bibContent <> hasCitations
|
||
where
|
||
bibContent = field "bibliography" $ \item -> do
|
||
bib <- itemBody <$> loadSnapshot (itemIdentifier item) "bibliography"
|
||
if null bib then fail "no bibliography" else return bib
|
||
hasCitations = field "has-citations" $ \item -> do
|
||
bib <- itemBody <$> (loadSnapshot (itemIdentifier item) "bibliography"
|
||
:: Compiler (Item String))
|
||
if null bib then fail "no citations" else return "true"
|
||
|
||
-- | Further-reading field: loads the further-reading HTML saved by essayCompiler.
|
||
-- Returns noResult (making $if(further-reading-refs)$ false) when empty.
|
||
furtherReadingField :: Context String
|
||
furtherReadingField = field "further-reading-refs" $ \item -> do
|
||
fr <- itemBody <$> (loadSnapshot (itemIdentifier item) "further-reading-refs"
|
||
:: Compiler (Item String))
|
||
if null fr then fail "no further reading" else return fr
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Epistemic fields
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Render an integer 1–5 frontmatter key as filled/empty dot chars.
|
||
-- Returns @noResult@ when the key is absent or unparseable.
|
||
dotsField :: String -> String -> Context String
|
||
dotsField ctxKey metaKey = field ctxKey $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case lookupString metaKey meta >>= readMaybe of
|
||
Nothing -> fail (ctxKey ++ ": not set")
|
||
Just (n :: Int) ->
|
||
let v = max 0 (min 5 n)
|
||
in return (replicate v '\x25CF' ++ replicate (5 - v) '\x25CB')
|
||
|
||
-- | @$confidence-trend$@: ↑, ↓, or → derived from the last two entries
|
||
-- in the @confidence-history@ frontmatter list. Returns @noResult@ when
|
||
-- there is no history or only a single entry.
|
||
--
|
||
-- The arrow flips when the absolute change crosses 'trendThreshold'
|
||
-- (currently 5 percentage points). Smaller swings count as flat.
|
||
confidenceTrendField :: Context String
|
||
confidenceTrendField = field "confidence-trend" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case lookupStringList "confidence-history" meta of
|
||
Nothing -> fail "no confidence history"
|
||
Just xs -> case lastTwo xs of
|
||
Nothing -> fail "no confidence history"
|
||
Just (prevS, curS) ->
|
||
let prev = readMaybe prevS :: Maybe Int
|
||
cur = readMaybe curS :: Maybe Int
|
||
in case (prev, cur) of
|
||
(Just p, Just c)
|
||
| c - p > trendThreshold -> return "\x2191" -- ↑
|
||
| p - c > trendThreshold -> return "\x2193" -- ↓
|
||
| otherwise -> return "\x2192" -- →
|
||
_ -> return "\x2192"
|
||
where
|
||
trendThreshold :: Int
|
||
trendThreshold = 5
|
||
|
||
-- Total replacement for @(xs !! (length xs - 2), last xs)@: returns
|
||
-- the last two elements of a list, in order, or 'Nothing' when the
|
||
-- list has fewer than two entries.
|
||
lastTwo :: [a] -> Maybe (a, a)
|
||
lastTwo [] = Nothing
|
||
lastTwo [_] = Nothing
|
||
lastTwo [a, b] = Just (a, b)
|
||
lastTwo (_ : rest) = lastTwo rest
|
||
|
||
-- | @$overall-score$@: weighted composite of confidence (60 %) and
|
||
-- evidence quality (40 %), expressed as an integer on a 0–100 scale.
|
||
--
|
||
-- Importance is intentionally excluded from the score: it answers
|
||
-- "should you read this?", not "should you trust it?", and folding
|
||
-- the two together inflated the number and muddied its meaning.
|
||
-- It still appears in the footer as an independent orientation
|
||
-- signal — just not as a credibility input.
|
||
--
|
||
-- The 1–5 evidence scale is rescaled as @(ev − 1) / 4@ rather than
|
||
-- plain @ev / 5@. The naive form left a hidden +6 floor (since
|
||
-- @1/5 = 0.2@) and a midpoint of 0.6 instead of 0.5; the rescale
|
||
-- makes evidence=1 contribute zero and evidence=3 contribute exactly
|
||
-- half, so a "true midpoint" entry (conf=50, ev=3) lands on 50.
|
||
--
|
||
-- Returns @noResult@ when confidence or evidence is absent, so
|
||
-- @$if(overall-score)$@ guards the template safely.
|
||
--
|
||
-- Formula: raw = conf/100 · 0.6 + (ev − 1)/4 · 0.4 (0–1)
|
||
-- score = clamp₀₋₁₀₀(round(raw · 100))
|
||
overallScoreField :: Context String
|
||
overallScoreField = field "overall-score" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let readInt s = readMaybe s :: Maybe Int
|
||
case ( readInt =<< lookupString "confidence" meta
|
||
, readInt =<< lookupString "evidence" meta
|
||
) 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 return (show score)
|
||
_ -> fail "overall-score: confidence or evidence not set"
|
||
|
||
-- | All epistemic context fields composed.
|
||
epistemicCtx :: Context String
|
||
epistemicCtx =
|
||
dotsField "importance-dots" "importance"
|
||
<> dotsField "evidence-dots" "evidence"
|
||
<> overallScoreField
|
||
<> confidenceTrendField
|
||
<> stabilityField
|
||
<> lastReviewedField
|
||
<> lastReviewedIsoField
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Essay context
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Display date (revision-aware)
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Resolve an item's display date as a 'UTCTime': the most-recent
|
||
-- 'revisionDateISO' if the item has a 'revised:' entry, else the
|
||
-- creation date via 'getItemUTC'. Falls back to the creation date
|
||
-- when a revision's ISO string fails to parse.
|
||
--
|
||
-- Shared by every revision-aware field below and by
|
||
-- 'recentFirstByDisplay', so they always agree on what the item's
|
||
-- display date is.
|
||
itemDisplayUTC :: Item a -> Compiler UTCTime
|
||
itemDisplayUTC item = do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case getRevisions meta of
|
||
(r:_) -> case parseTimeM True defaultTimeLocale "%Y-%m-%d"
|
||
(revisionDateISO r) :: Maybe UTCTime of
|
||
Just utc -> return utc
|
||
Nothing -> getItemUTC defaultTimeLocale (itemIdentifier item)
|
||
[] -> getItemUTC defaultTimeLocale (itemIdentifier item)
|
||
|
||
-- | @$date-display$@ — the date shown next to an item in list renderings.
|
||
-- Most-recent revision date if the item has a 'revised:' entry, else
|
||
-- its creation date. Formatted "17 April 2026".
|
||
dateDisplayField :: Context String
|
||
dateDisplayField = field "date-display" $ \item ->
|
||
formatTime defaultTimeLocale "%-d %B %Y" <$> itemDisplayUTC item
|
||
|
||
-- | @$date-iso$@ — ISO-8601 form of the display date, for
|
||
-- @<time datetime="...">@ attributes. Same revision-aware
|
||
-- semantics as 'dateDisplayField'.
|
||
dateDisplayIsoField :: Context String
|
||
dateDisplayIsoField = field "date-iso" $ \item ->
|
||
formatTime defaultTimeLocale "%Y-%m-%d" <$> itemDisplayUTC item
|
||
|
||
-- | @$date-original$@ — the item's creation date, present in the
|
||
-- context only when the most-recent revision date differs from it.
|
||
-- Consumed by the card partial's "· revised from …" annotation.
|
||
-- 'noResult' otherwise (so the annotation is simply absent for
|
||
-- never-revised items).
|
||
dateOriginalField :: Context String
|
||
dateOriginalField = field "date-original" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case getRevisions meta of
|
||
[] -> noResult "no revisions"
|
||
(r:_) -> do
|
||
created <- getItemUTC defaultTimeLocale (itemIdentifier item)
|
||
let createdIso = formatTime defaultTimeLocale "%Y-%m-%d" created
|
||
if revisionDateISO r == createdIso
|
||
then noResult "revision date equals creation date"
|
||
else return (formatTime defaultTimeLocale "%-d %B %Y" created)
|
||
|
||
-- | @$revision-note$@ — prose note attached to the most-recent
|
||
-- 'revised:' entry, if any. Rendered as an italicized line under
|
||
-- the abstract on the item card. 'noResult' when there's no
|
||
-- revision, or when the most-recent revision has no note.
|
||
revisionNoteField :: Context String
|
||
revisionNoteField = field "revision-note" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case getRevisions meta of
|
||
(r:_) | Just note <- revisionNote r, not (null (trim note)) -> return note
|
||
_ -> noResult "no revision note"
|
||
|
||
-- | Bundle of revision-aware fields consumed by the item-card partial:
|
||
-- @$date-display$@, @$date-iso$@, @$date-original$@, @$revision-note$@.
|
||
-- Compose once on any surface that renders item cards.
|
||
revisionDateFields :: Context String
|
||
revisionDateFields =
|
||
dateDisplayField
|
||
<> dateDisplayIsoField
|
||
<> dateOriginalField
|
||
<> revisionNoteField
|
||
|
||
-- | Sort items most-recent-first by 'itemDisplayUTC' — same ordering
|
||
-- the card shows in its date gutter, so items with recent revisions
|
||
-- move to the top without divorcing the sort key from the visible
|
||
-- date. Callers: the @/new.html@ rule, 'Tags.applyTagRules', and
|
||
-- the library rule.
|
||
recentFirstByDisplay :: [Item a] -> Compiler [Item a]
|
||
recentFirstByDisplay items = do
|
||
keyed <- mapM (\i -> (,) <$> itemDisplayUTC i <*> pure i) items
|
||
return $ map snd $ sortBy (flip (comparing fst)) keyed
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Revised: frontmatter schema
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | A single entry from a @revised:@ frontmatter list. Exposed so
|
||
-- downstream Phase-5 consumers (the 'dateDisplayField' implementation
|
||
-- and the revision-annotation fields on the item card) can all read
|
||
-- the same canonical form.
|
||
data Revision = Revision
|
||
{ revisionDateISO :: String -- ^ ISO-8601 date, e.g. "2026-04-10"
|
||
, revisionNote :: Maybe String -- ^ optional prose note for the entry
|
||
}
|
||
|
||
-- | Parse and normalize the @revised:@ frontmatter field into a list
|
||
-- of 'Revision' entries, sorted most-recent-first (ISO @YYYY-MM-DD@
|
||
-- strings sort lexicographically in chronological order, so
|
||
-- reverse-sorting them yields most-recent-first).
|
||
--
|
||
-- Accepted frontmatter shapes:
|
||
--
|
||
-- @
|
||
-- -- Scalar shorthand (normalized to one entry with no note)
|
||
-- revised: "2026-04-10"
|
||
--
|
||
-- -- Canonical list of objects
|
||
-- revised:
|
||
-- - date: "2026-04-10"
|
||
-- note: "expanded §3 on Shestov"
|
||
-- - date: "2025-12-03" -- note optional per-entry
|
||
-- @
|
||
--
|
||
-- The two shapes normalize to the same list-of-'Revision' form here.
|
||
-- No other site code should branch on the frontmatter shape —
|
||
-- everything downstream reads this function's output.
|
||
--
|
||
-- Entries that fail to parse (missing @date:@, non-string values,
|
||
-- unexpected types) are silently dropped rather than erroring the
|
||
-- whole build; the site still compiles with a malformed @revised:@.
|
||
getRevisions :: Metadata -> [Revision]
|
||
getRevisions meta =
|
||
sortBy (flip (comparing revisionDateISO)) $
|
||
case KM.lookup "revised" meta of
|
||
Just (String t) -> [Revision (T.unpack t) Nothing]
|
||
Just (Array v) -> mapMaybe parseEntry (V.toList v)
|
||
_ -> []
|
||
where
|
||
parseEntry (Object o) = do
|
||
d <- getString =<< KM.lookup "date" o
|
||
return (Revision d (getString =<< KM.lookup "note" o))
|
||
parseEntry _ = Nothing
|
||
|
||
getString (String t) = Just (T.unpack t)
|
||
getString _ = Nothing
|
||
|
||
essayCtx :: Context String
|
||
essayCtx =
|
||
authorLinksField
|
||
<> affiliationField
|
||
<> snapshotField "toc" "toc"
|
||
<> snapshotField "word-count" "word-count"
|
||
<> snapshotField "reading-time" "reading-time"
|
||
<> bibliographyField
|
||
<> furtherReadingField
|
||
<> backlinksField
|
||
<> similarLinksField
|
||
<> epistemicCtx
|
||
<> versionHistoryField
|
||
<> versionHistoryPrimaryField
|
||
<> versionHistoryRestField
|
||
<> versionHistoryRangeField
|
||
<> versionHistoryRangeStartField
|
||
<> versionHistoryRangeEndField
|
||
<> versionHistoryCommitsField
|
||
<> dateField "date-created" "%-d %B %Y"
|
||
<> dateField "date-modified" "%-d %B %Y"
|
||
<> revisionDateFields
|
||
<> constField "math" "true"
|
||
<> tagLinksField "essay-tags"
|
||
<> keywordLinksField "essay-keywords"
|
||
<> siteCtx
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Post context
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
postCtx :: Context String
|
||
postCtx =
|
||
authorLinksField
|
||
<> affiliationField
|
||
<> backlinksField
|
||
<> similarLinksField
|
||
<> dateField "date" "%-d %B %Y"
|
||
<> dateField "date-iso" "%Y-%m-%d"
|
||
<> constField "math" "true"
|
||
<> siteCtx
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Page context
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
pageCtx :: Context String
|
||
pageCtx = authorLinksField <> affiliationField <> siteCtx
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Reading contexts (fiction + poetry)
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Base reading context: essay fields + the "reading" flag (activates
|
||
-- reading.css / reading.js via head.html and body class via default.html).
|
||
readingCtx :: Context String
|
||
readingCtx = essayCtx <> constField "reading" "true"
|
||
|
||
-- | Poetry context: reading mode + "poetry" flag for CSS body class.
|
||
poetryCtx :: Context String
|
||
poetryCtx = readingCtx <> constField "poetry" "true"
|
||
|
||
-- | Fiction context: reading mode + "fiction" flag for CSS body class.
|
||
fictionCtx :: Context String
|
||
fictionCtx = readingCtx <> constField "fiction" "true"
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Composition context (music landing pages + score reader)
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
data Movement = Movement
|
||
{ movName :: String
|
||
, movPage :: Int
|
||
, movDuration :: String
|
||
, movAudio :: Maybe String
|
||
}
|
||
|
||
-- | Parse the @movements@ frontmatter key. Returns parsed movements and a
|
||
-- list of human-readable warnings for any entries that failed to parse.
|
||
-- Callers can surface the warnings via 'unsafeCompiler' so silent typos
|
||
-- don't strip movements without diagnostic.
|
||
parseMovementsWithWarnings :: Metadata -> ([Movement], [String])
|
||
parseMovementsWithWarnings meta =
|
||
case KM.lookup "movements" meta of
|
||
Just (Array v) ->
|
||
let results = zipWith parseIndexed [1 :: Int ..] (V.toList v)
|
||
in ( [m | Right m <- results]
|
||
, [w | Left w <- results]
|
||
)
|
||
_ -> ([], [])
|
||
where
|
||
parseIndexed i value =
|
||
case parseOne value of
|
||
Just m -> Right m
|
||
Nothing -> Left $
|
||
"movement #" ++ show i ++ " is missing a required field "
|
||
++ "(name, page, or duration) — entry skipped"
|
||
|
||
parseOne (Object o) = Movement
|
||
<$> (getString =<< KM.lookup "name" o)
|
||
<*> (getInt =<< KM.lookup "page" o)
|
||
<*> (getString =<< KM.lookup "duration" o)
|
||
<*> pure (getString =<< KM.lookup "audio" o)
|
||
parseOne _ = Nothing
|
||
|
||
getString (String t) = Just (T.unpack t)
|
||
getString _ = Nothing
|
||
|
||
getInt (Number n) = Just (floor (fromRational (toRational n) :: Double))
|
||
getInt _ = Nothing
|
||
|
||
parseMovements :: Metadata -> [Movement]
|
||
parseMovements = fst . parseMovementsWithWarnings
|
||
|
||
-- | Extract the composition slug from an item's identifier.
|
||
-- "content/music/symphonic-dances/index.md" → "symphonic-dances"
|
||
compSlug :: Item a -> String
|
||
compSlug = takeFileName . takeDirectory . toFilePath . itemIdentifier
|
||
|
||
-- | Context for music composition landing pages and the score reader.
|
||
-- Extends essayCtx with composition-specific fields:
|
||
-- $slug$ — URL slug (e.g. "symphonic-dances")
|
||
-- $score-url$ — absolute URL of the score reader page
|
||
-- $has-score$ — present when score-pages frontmatter is non-empty
|
||
-- $score-page-count$ — total number of score pages
|
||
-- $score-pages$ — list of {score-page-url} items
|
||
-- $has-movements$ — present when movements frontmatter is non-empty
|
||
-- $movements$ — list of {movement-name, movement-page,
|
||
-- movement-duration, movement-audio, has-audio}
|
||
-- All other frontmatter keys (instrumentation, duration, premiere,
|
||
-- commissioned-by, pdf, abstract, etc.) are available via defaultContext.
|
||
compositionCtx :: Context String
|
||
compositionCtx =
|
||
constField "composition" "true"
|
||
<> slugField
|
||
<> scoreUrlField
|
||
<> hasScoreField
|
||
<> scorePageCountField
|
||
<> scorePagesListField
|
||
<> hasMovementsField
|
||
<> movementsListField
|
||
<> essayCtx
|
||
where
|
||
slugField = field "slug" (return . compSlug)
|
||
|
||
scoreUrlField = field "score-url" $ \item ->
|
||
return $ "/music/" ++ compSlug item ++ "/score/"
|
||
|
||
hasScoreField = field "has-score" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let pages = fromMaybe [] (lookupStringList "score-pages" meta)
|
||
if null pages then fail "no score pages" else return "true"
|
||
|
||
scorePageCountField = field "score-page-count" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let pages = fromMaybe [] (lookupStringList "score-pages" meta)
|
||
return $ show (length pages)
|
||
|
||
scorePagesListField = listFieldWith "score-pages" spCtx $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let slug = compSlug item
|
||
base = "/music/" ++ slug ++ "/"
|
||
pages = fromMaybe [] (lookupStringList "score-pages" meta)
|
||
return $ map (\p -> Item (fromFilePath p) (base ++ p)) pages
|
||
where
|
||
spCtx = field "score-page-url" (return . itemBody)
|
||
|
||
hasMovementsField = field "has-movements" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
if null (parseMovements meta) then fail "no movements" else return "true"
|
||
|
||
movementsListField = listFieldWith "movements" movCtx $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
let (mvs, warnings) = parseMovementsWithWarnings meta
|
||
ident = toFilePath (itemIdentifier item)
|
||
unsafeCompiler $ mapM_
|
||
(\w -> putStrLn $ "[Movements] " ++ ident ++ ": " ++ w)
|
||
warnings
|
||
return $ zipWith
|
||
(\idx mv -> Item (fromFilePath ("mv" ++ show (idx :: Int))) mv)
|
||
[1..] mvs
|
||
where
|
||
movCtx =
|
||
field "movement-name" (return . movName . itemBody)
|
||
<> field "movement-page" (return . show . movPage . itemBody)
|
||
<> field "movement-duration" (return . movDuration . itemBody)
|
||
<> field "movement-audio"
|
||
(\i -> maybe (fail "no audio") return (movAudio (itemBody i)))
|
||
<> field "has-audio"
|
||
(\i -> maybe (fail "no audio") (const (return "true"))
|
||
(movAudio (itemBody i)))
|