380 lines
16 KiB
Haskell
380 lines
16 KiB
Haskell
{-# LANGUAGE GHC2021 #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
module Contexts
|
||
( siteCtx
|
||
, essayCtx
|
||
, postCtx
|
||
, pageCtx
|
||
, poetryCtx
|
||
, fictionCtx
|
||
, compositionCtx
|
||
) where
|
||
|
||
import Data.Aeson (Value (..))
|
||
import qualified Data.Aeson.KeyMap as KM
|
||
import qualified Data.Vector as V
|
||
import Data.Maybe (catMaybes, fromMaybe)
|
||
import Data.Time.Calendar (toGregorian)
|
||
import Data.Time.Clock (getCurrentTime, utctDay)
|
||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||
import System.FilePath (takeDirectory, takeFileName)
|
||
import Text.Read (readMaybe)
|
||
import qualified Data.Text as T
|
||
import Hakyll
|
||
import Hakyll.Core.Metadata (lookupStringList)
|
||
import Authors (authorLinksField)
|
||
import Backlinks (backlinksField)
|
||
import SimilarLinks (similarLinksField)
|
||
import Stability (stabilityField, lastReviewedField, versionHistoryField)
|
||
import Tags (tagLinksField)
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- 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"
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- 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.
|
||
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)
|
||
return $ map (\s -> Item (fromFilePath s) s) scripts
|
||
where
|
||
ctx = field "script-src" (return . itemBody)
|
||
|
||
siteCtx :: Context String
|
||
siteCtx =
|
||
constField "site-title" "Levi Neuwirth"
|
||
<> constField "site-url" "https://levineuwirth.org"
|
||
<> buildTimeField
|
||
<> pageScriptsField
|
||
<> 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.
|
||
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 | length xs < 2 -> fail "no confidence history"
|
||
Just xs ->
|
||
let prev = readMaybe (xs !! (length xs - 2)) :: Maybe Int
|
||
cur = readMaybe (last xs) :: Maybe Int
|
||
in case (prev, cur) of
|
||
(Just p, Just c)
|
||
| c - p > 5 -> return "\x2191" -- ↑
|
||
| p - c > 5 -> return "\x2193" -- ↓
|
||
| otherwise -> return "\x2192" -- →
|
||
_ -> return "\x2192"
|
||
|
||
-- | @$overall-score$@: weighted composite of confidence (50 %),
|
||
-- evidence quality (30 %), and importance (20 %), expressed as an
|
||
-- integer on a 0–100 scale.
|
||
-- Returns @noResult@ when any contributing field is absent, so
|
||
-- @$if(overall-score)$@ guards the template safely.
|
||
--
|
||
-- Formula: raw = conf/100·0.5 + ev/5·0.3 + imp/5·0.2 (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
|
||
, readInt =<< lookupString "importance" meta
|
||
) of
|
||
(Just conf, Just ev, Just imp) ->
|
||
let raw :: Double
|
||
raw = fromIntegral conf / 100.0 * 0.5
|
||
+ fromIntegral ev / 5.0 * 0.3
|
||
+ fromIntegral imp / 5.0 * 0.2
|
||
score = max 0 (min 100 (round (raw * 100.0) :: Int))
|
||
in return (show score)
|
||
_ -> fail "overall-score: confidence, evidence, or importance not set"
|
||
|
||
-- | All epistemic context fields composed.
|
||
epistemicCtx :: Context String
|
||
epistemicCtx =
|
||
dotsField "importance-dots" "importance"
|
||
<> dotsField "evidence-dots" "evidence"
|
||
<> overallScoreField
|
||
<> confidenceTrendField
|
||
<> stabilityField
|
||
<> lastReviewedField
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Essay context
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
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
|
||
<> dateField "date-created" "%-d %B %Y"
|
||
<> dateField "date-modified" "%-d %B %Y"
|
||
<> constField "math" "true"
|
||
<> tagLinksField "essay-tags"
|
||
<> 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
|
||
}
|
||
|
||
parseMovements :: Metadata -> [Movement]
|
||
parseMovements meta =
|
||
case KM.lookup "movements" meta of
|
||
Just (Array v) -> catMaybes $ map parseOne (V.toList v)
|
||
_ -> []
|
||
where
|
||
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
|
||
|
||
-- | 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 = parseMovements meta
|
||
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)))
|