563 lines
25 KiB
Haskell
563 lines
25 KiB
Haskell
{-# LANGUAGE GHC2021 #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
-- | Frontmatter marks: the monogram (a hand-authored SVG per piece) and
|
||
-- the epistemic figure (a build-time SVG generated from frontmatter).
|
||
-- See MARKS.md for the full specification.
|
||
--
|
||
-- Two Hakyll context fields are exported:
|
||
--
|
||
-- * @$monogramSvg$@ — the inlined monogram for the current item, or
|
||
-- 'noResult' when no co-located @mark.svg@ exists.
|
||
-- * @$epistemicSvg$@ — the generated epistemic figure, or 'noResult'
|
||
-- when the item has no @status:@ frontmatter
|
||
-- (MARKS.md §3.1).
|
||
--
|
||
-- Both fields are deterministic: byte-identical inputs produce
|
||
-- byte-identical SVGs, so the GPG signing pipeline is undisturbed.
|
||
module Marks
|
||
( monogramSvgField
|
||
, epistemicSvgField
|
||
) where
|
||
|
||
import Control.Exception (IOException, try)
|
||
import Data.Char (toLower)
|
||
import Data.Maybe (catMaybes, isJust)
|
||
import qualified Data.Text as T
|
||
import qualified Data.Text.IO as TIO
|
||
import Numeric (showFFloat)
|
||
import System.Directory (doesFileExist)
|
||
import System.FilePath (takeBaseName, takeDirectory,
|
||
takeFileName, (</>))
|
||
import System.IO (hPutStrLn, stderr)
|
||
import Text.Read (readMaybe)
|
||
|
||
import Hakyll
|
||
import Stability (resolveStability)
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Monogram path resolution
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Candidate monogram paths for a given source path. The build picks the
|
||
-- first one that exists on disk. This dual-form resolver matches the
|
||
-- site's mixed flat / directory essay convention:
|
||
--
|
||
-- > content/essays/foo.md → content/essays/foo.mark.svg
|
||
-- > content/essays/foo/index.md → content/essays/foo/mark.svg
|
||
monogramCandidates :: FilePath -> [FilePath]
|
||
monogramCandidates fp =
|
||
let dir = takeDirectory fp
|
||
fname = takeFileName fp
|
||
in if fname == "index.md"
|
||
then [dir </> "mark.svg"]
|
||
else [dir </> takeBaseName fp ++ ".mark.svg"]
|
||
|
||
-- | Return the first candidate path that exists on disk, or 'Nothing'.
|
||
resolveMonogramPath :: Item a -> Compiler (Maybe FilePath)
|
||
resolveMonogramPath item =
|
||
unsafeCompiler $ firstExisting (monogramCandidates fp)
|
||
where
|
||
fp = toFilePath (itemIdentifier item)
|
||
firstExisting [] = return Nothing
|
||
firstExisting (p:ps) = do
|
||
e <- doesFileExist p
|
||
if e then return (Just p) else firstExisting ps
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Monogram inlining
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | @$monogramSvg$@. Reads the resolved @mark.svg@, normalizes black
|
||
-- fills/strokes to @currentColor@ (defensive — authors using AI-assist
|
||
-- tools may produce hardcoded blacks; the contract still holds), strips
|
||
-- the @width@/@height@ presentation attributes from the root @<svg>@,
|
||
-- and wraps the result in @<figure class="frontmatter-mark
|
||
-- frontmatter-mark--monogram">@. Returns 'noResult' when no candidate
|
||
-- exists; warns and returns 'noResult' on read failure.
|
||
monogramSvgField :: Context String
|
||
monogramSvgField = field "monogramSvg" $ \item -> do
|
||
mPath <- resolveMonogramPath item
|
||
case mPath of
|
||
Nothing -> noResult "no mark.svg"
|
||
Just path -> do
|
||
result <- unsafeCompiler $ try (TIO.readFile path)
|
||
:: Compiler (Either IOException T.Text)
|
||
case result of
|
||
Left e -> do
|
||
unsafeCompiler $ hPutStrLn stderr $
|
||
"[Marks] " ++ toFilePath (itemIdentifier item) ++
|
||
": failed to read " ++ path ++ ": " ++ show e
|
||
noResult "monogram read failed"
|
||
Right svg -> return $ T.unpack $ wrapMonogram (processSvg svg)
|
||
|
||
-- | Wrap inlined monogram SVG in its outer figure element.
|
||
wrapMonogram :: T.Text -> T.Text
|
||
wrapMonogram svg = T.concat
|
||
[ "<figure class=\"frontmatter-mark frontmatter-mark--monogram\">"
|
||
, svg
|
||
, "</figure>"
|
||
]
|
||
|
||
-- | Replace hardcoded black fills/strokes with @currentColor@ and strip
|
||
-- the root @<svg>@'s @width@/@height@ attributes (presentation lives
|
||
-- in CSS via the @.frontmatter-mark svg@ selector). Mirrors the color
|
||
-- substitution in 'Filters.Score.processColors' so the two SVG
|
||
-- inliners agree on the contract.
|
||
processSvg :: T.Text -> T.Text
|
||
processSvg = stripRootDims . normalizeColors
|
||
|
||
-- | The same chain 'Filters.Score' applies, kept in sync deliberately.
|
||
-- 6-digit patterns first so the 3-digit replacement doesn't match
|
||
-- the prefix of a 6-digit value.
|
||
normalizeColors :: T.Text -> T.Text
|
||
normalizeColors
|
||
= T.replace "fill=\"#000\"" "fill=\"currentColor\""
|
||
. T.replace "fill=\"black\"" "fill=\"currentColor\""
|
||
. T.replace "stroke=\"#000\"" "stroke=\"currentColor\""
|
||
. T.replace "stroke=\"black\"" "stroke=\"currentColor\""
|
||
. T.replace "fill:#000" "fill:currentColor"
|
||
. T.replace "fill:black" "fill:currentColor"
|
||
. T.replace "stroke:#000" "stroke:currentColor"
|
||
. T.replace "stroke:black" "stroke:currentColor"
|
||
. T.replace "fill=\"#000000\"" "fill=\"currentColor\""
|
||
. T.replace "stroke=\"#000000\"" "stroke=\"currentColor\""
|
||
. T.replace "fill:#000000" "fill:currentColor"
|
||
. T.replace "stroke:#000000" "stroke:currentColor"
|
||
|
||
-- | Remove @width="..."@ and @height="..."@ from the root @<svg>@.
|
||
-- The substitution is conservative: it walks once and only touches
|
||
-- the first occurrence of each attribute (the root tag in a
|
||
-- well-formed monogram).
|
||
stripRootDims :: T.Text -> T.Text
|
||
stripRootDims = stripFirst "width" . stripFirst "height"
|
||
where
|
||
stripFirst attr txt =
|
||
case T.breakOn (T.pack (" " ++ attr ++ "=\"")) txt of
|
||
(before, after)
|
||
| T.null after -> txt
|
||
| otherwise ->
|
||
-- Drop ` attr="..."` including its closing quote.
|
||
let restAfterEq = T.drop (T.length (T.pack (" " ++ attr ++ "=\""))) after
|
||
in case T.breakOn "\"" restAfterEq of
|
||
(_, rest) | T.null rest -> txt
|
||
| otherwise -> before <> T.drop 1 rest
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Epistemic figure: data extraction
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Captures the frontmatter inputs the figure consumes. Constructed
|
||
-- once per item by 'readEpistemicData', then handed to the pure
|
||
-- geometry below. Keeps the I/O step (metadata + git) separate from
|
||
-- the SVG-string formatter, so the formatter is testable in isolation
|
||
-- without mocking Hakyll.
|
||
data EpistemicData = EpistemicData
|
||
{ epConfidence :: Maybe Int -- ^ Numeric confidence; 'Nothing' if proved/absent/unparseable.
|
||
, epConfidenceProved :: Bool -- ^ True when @confidence: proved@ / @proven@.
|
||
, epImportance :: Maybe Int -- ^ 1–5 ordinal.
|
||
, epEvidence :: Maybe Int -- ^ 1–5 ordinal.
|
||
, epScope :: Maybe String -- ^ Validated scope value.
|
||
, epNovelty :: Maybe String -- ^ Validated novelty value.
|
||
, epPracticality :: Maybe String -- ^ Validated practicality value.
|
||
, epPeerStatus :: Maybe String -- ^ Validated peer-status slug ('Nothing' when absent / unreviewed / invalid).
|
||
, epResultShape :: Maybe String -- ^ Validated result-shape value.
|
||
, epStability :: String -- ^ Always one of the five stability labels.
|
||
, epTrust :: Int -- ^ Trust score 0–100 (60/40 weighted; @proved@ substitutes 100 for confidence).
|
||
}
|
||
|
||
-- | Read the figure inputs from a Hakyll item's metadata + git history.
|
||
readEpistemicData :: Item a -> Compiler EpistemicData
|
||
readEpistemicData item = do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
stab <- resolveStability item
|
||
let confRaw = lookupString "confidence" meta
|
||
proved = isProvedConfidenceM confRaw
|
||
confInt = if proved then Just 100 else readMaybe . trimS =<< confRaw
|
||
confNumeric = if proved then Nothing else confInt
|
||
importance = readMaybe . trimS =<< lookupString "importance" meta
|
||
evidence = readMaybe . trimS =<< lookupString "evidence" meta
|
||
scope = validate scopeValues =<< lookupString "scope" meta
|
||
novelty = validate noveltyValues =<< lookupString "novelty" meta
|
||
practical = validate practicalityValues =<< lookupString "practicality" meta
|
||
peer = validatePeerStatus =<< lookupString "peer-status" meta
|
||
resultShape = validate resultShapeValues =<< lookupString "result-shape" meta
|
||
trust = computeTrust confInt evidence
|
||
return EpistemicData
|
||
{ epConfidence = confNumeric
|
||
, epConfidenceProved = proved
|
||
, epImportance = importance
|
||
, epEvidence = evidence
|
||
, epScope = scope
|
||
, epNovelty = novelty
|
||
, epPracticality = practical
|
||
, epPeerStatus = peer
|
||
, epResultShape = resultShape
|
||
, epStability = stab
|
||
, epTrust = trust
|
||
}
|
||
where
|
||
trimS = trim'
|
||
|
||
-- | Trust score: the same 60/40 weighted composite of confidence and
|
||
-- evidence used by 'Contexts.overallScoreField'. Returns 0 when either
|
||
-- input is missing — which is fine for the figure (the polygon and
|
||
-- trust label simply collapse to the bare frame).
|
||
computeTrust :: Maybe Int -> Maybe Int -> Int
|
||
computeTrust (Just c) (Just e) =
|
||
let raw :: Double
|
||
raw = fromIntegral c / 100.0 * 0.6 + fromIntegral (e - 1) / 4.0 * 0.4
|
||
in max 0 (min 100 (round (raw * 100.0)))
|
||
computeTrust _ _ = 0
|
||
|
||
-- | Same predicate as 'Contexts.isProvedConfidence' — local copy to keep
|
||
-- the module's dependency graph light (Marks → Stability only). The
|
||
-- two are tested against the same vocabulary; if either drifts the
|
||
-- build still warns via the schema validators in Contexts.hs.
|
||
isProvedConfidenceM :: Maybe String -> Bool
|
||
isProvedConfidenceM (Just s) = map toLower (trim' s) `elem` ["proved", "proven"]
|
||
isProvedConfidenceM _ = False
|
||
|
||
trim' :: String -> String
|
||
trim' = f . f
|
||
where f = reverse . dropWhile (`elem` (" \t\n\r" :: String))
|
||
|
||
-- | Validate a value against an enum list. Returns the lowercase form
|
||
-- on hit, 'Nothing' otherwise (no warning here — Contexts.hs's parsers
|
||
-- already warn on invalid frontmatter; the figure simply degrades).
|
||
validate :: [String] -> String -> Maybe String
|
||
validate vs raw =
|
||
let s = map toLower (trim' raw)
|
||
in if s `elem` vs then Just s else Nothing
|
||
|
||
-- | Peer-status validator: matches @peerStatusField@ in Contexts.hs but
|
||
-- maps @unreviewed@ to 'Nothing' so the figure's outer ring stays
|
||
-- neutral by default.
|
||
validatePeerStatus :: String -> Maybe String
|
||
validatePeerStatus raw =
|
||
let s = map toLower (trim' raw)
|
||
in if s `elem` ["under-review", "peer-reviewed", "published", "retracted"]
|
||
then Just s
|
||
else Nothing -- includes "unreviewed" and any unknown value
|
||
|
||
scopeValues, noveltyValues, practicalityValues, resultShapeValues :: [String]
|
||
scopeValues = ["personal", "local", "average", "broad", "civilizational"]
|
||
noveltyValues = ["conventional", "moderate", "idiosyncratic", "innovative"]
|
||
practicalityValues = ["abstract", "low", "moderate", "high", "exceptional"]
|
||
resultShapeValues = ["positive", "negative", "mixed", "comparative", "descriptive"]
|
||
|
||
-- | Map an ordinal value to its numeric rank (1-based).
|
||
ordinalRank :: [String] -> String -> Maybe Int
|
||
ordinalRank vs s = lookup s (zip vs [1..])
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Epistemic figure: geometry
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Centre of the figure (viewBox coordinates).
|
||
fxCenter, fyCenter :: Double
|
||
fxCenter = 100
|
||
fyCenter = 100
|
||
|
||
-- | Inner / outer radii of the roundel and the polygon's full extent.
|
||
fxOuter, fxOuterPlus, fxAxisFull :: Double
|
||
fxOuter = 88 -- inner roundel circle
|
||
fxOuterPlus = 90 -- outer roundel circle
|
||
fxAxisFull = 80 -- full axis length (polygon vertex when value = 1.0)
|
||
|
||
-- | Six axis angles, clockwise from 12 o'clock, in degrees.
|
||
-- Index → field: 0 confidence, 1 novelty, 2 practicality,
|
||
-- 3 scope, 4 evidence, 5 importance.
|
||
axisAngles :: [Double]
|
||
axisAngles = [0, 60, 120, 180, 240, 300]
|
||
|
||
-- | Convert a (clockwise-angle-from-12-o'clock, distance-from-centre) pair
|
||
-- to absolute viewBox coordinates.
|
||
polar :: Double -> Double -> (Double, Double)
|
||
polar angleDeg dist =
|
||
let theta = (angleDeg - 90) * pi / 180
|
||
in (fxCenter + dist * cos theta, fyCenter + dist * sin theta)
|
||
|
||
-- | Axis index → normalized [0,1] value, or 'Nothing' when the
|
||
-- underlying frontmatter field is absent / unparseable.
|
||
axisValue :: EpistemicData -> Int -> Maybe Double
|
||
axisValue d i = case i of
|
||
0 -> if epConfidenceProved d
|
||
then Just 1.0
|
||
else fmap (\c -> fromIntegral c / 100.0) (epConfidence d)
|
||
1 -> normalizeOrdinal noveltyValues 4 (epNovelty d)
|
||
2 -> normalizeOrdinal practicalityValues 5 (epPracticality d)
|
||
3 -> normalizeOrdinal scopeValues 5 (epScope d)
|
||
4 -> normalizeIntScale 5 (epEvidence d)
|
||
5 -> normalizeIntScale 5 (epImportance d)
|
||
_ -> Nothing
|
||
|
||
-- | Map a 1..n ordinal-name value to a [0,1] value via @(rank-1)/(n-1)@.
|
||
normalizeOrdinal :: [String] -> Int -> Maybe String -> Maybe Double
|
||
normalizeOrdinal vs n (Just s) = do
|
||
r <- ordinalRank vs s
|
||
return $ fromIntegral (r - 1) / fromIntegral (n - 1)
|
||
normalizeOrdinal _ _ Nothing = Nothing
|
||
|
||
-- | Map a 1..n integer to [0,1] via @(v-1)/(n-1)@.
|
||
normalizeIntScale :: Int -> Maybe Int -> Maybe Double
|
||
normalizeIntScale n (Just v) = Just $ fromIntegral (v - 1) / fromIntegral (n - 1)
|
||
normalizeIntScale _ Nothing = Nothing
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Epistemic figure: SVG rendering
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | Format a Double with two decimal places. Determinism (§8.1) requires
|
||
-- no platform-dependent floating-point formatting.
|
||
ff :: Double -> T.Text
|
||
ff x = T.pack (showFFloat (Just 2) x "")
|
||
|
||
-- | Format a "x,y" coordinate pair.
|
||
xy :: Double -> Double -> T.Text
|
||
xy x y = ff x <> T.singleton ',' <> ff y
|
||
|
||
-- | Render the full epistemic figure SVG.
|
||
renderEpistemicFigure :: EpistemicData -> T.Text
|
||
renderEpistemicFigure d = T.concat
|
||
[ "<svg xmlns=\"http://www.w3.org/2000/svg\""
|
||
, " viewBox=\"0 0 200 200\""
|
||
, " role=\"img\""
|
||
, " aria-label=\"Epistemic figure: trust ", T.pack (show (epTrust d))
|
||
, ", stability ", T.pack (epStability d), "\">"
|
||
, renderRoundel
|
||
, renderGuides
|
||
, renderAxes
|
||
, renderPolygon d
|
||
, renderVertexMarks d
|
||
, renderTicks (epStability d) (epPeerStatus d)
|
||
, renderTrustLabel (epTrust d)
|
||
, renderResultShape (epResultShape d) (epTrust d)
|
||
, "</svg>"
|
||
]
|
||
|
||
-- | Two thin concentric circles forming the outer roundel.
|
||
renderRoundel :: T.Text
|
||
renderRoundel = T.concat
|
||
[ "<circle cx=\"", ff fxCenter, "\" cy=\"", ff fyCenter
|
||
, "\" r=\"", ff fxOuter
|
||
, "\" fill=\"none\" stroke=\"currentColor\" stroke-width=\"0.5\" opacity=\"0.7\"/>"
|
||
, "<circle cx=\"", ff fxCenter, "\" cy=\"", ff fyCenter
|
||
, "\" r=\"", ff fxOuterPlus
|
||
, "\" fill=\"none\" stroke=\"currentColor\" stroke-width=\"0.5\" opacity=\"0.7\"/>"
|
||
]
|
||
|
||
-- | Four concentric guide circles at 0.2 R, 0.4 R, 0.6 R, 0.8 R.
|
||
renderGuides :: T.Text
|
||
renderGuides = T.concat $ map oneGuide [0.2, 0.4, 0.6, 0.8 :: Double]
|
||
where
|
||
oneGuide t = T.concat
|
||
[ "<circle cx=\"", ff fxCenter, "\" cy=\"", ff fyCenter
|
||
, "\" r=\"", ff (fxAxisFull * t)
|
||
, "\" fill=\"none\" stroke=\"currentColor\""
|
||
, " stroke-width=\"0.25\" opacity=\"0.4\"/>"
|
||
]
|
||
|
||
-- | Six radial axes from centre to the inner roundel.
|
||
renderAxes :: T.Text
|
||
renderAxes = T.concat $ map oneAxis axisAngles
|
||
where
|
||
oneAxis a =
|
||
let (x, y) = polar a fxAxisFull
|
||
in T.concat
|
||
[ "<line x1=\"", ff fxCenter, "\" y1=\"", ff fyCenter
|
||
, "\" x2=\"", ff x, "\" y2=\"", ff y
|
||
, "\" stroke=\"currentColor\" stroke-width=\"0.3\" opacity=\"0.55\"/>"
|
||
]
|
||
|
||
-- | Polygon connecting the present field values along their axes.
|
||
-- When all six axes have a value the polygon is closed; otherwise
|
||
-- it's an open polyline through the present vertices in axis order.
|
||
renderPolygon :: EpistemicData -> T.Text
|
||
renderPolygon d =
|
||
let pairs = [ (i, axisValue d i) | i <- [0..5] ]
|
||
verts = [ polar a (fxAxisFull * v)
|
||
| (i, Just v) <- pairs
|
||
, let a = axisAngles !! i ]
|
||
in case verts of
|
||
[] -> ""
|
||
_ ->
|
||
let pointsTxt = T.intercalate " " [ xy x y | (x, y) <- verts ]
|
||
allPresent = all (isJust . snd) pairs
|
||
tag = if allPresent then "polygon" else "polyline"
|
||
fillAttr = if allPresent
|
||
then " fill=\"currentColor\" fill-opacity=\"0.08\""
|
||
else " fill=\"none\""
|
||
in T.concat
|
||
[ "<", tag
|
||
, " points=\"", pointsTxt
|
||
, "\" stroke=\"currentColor\" stroke-width=\"1.1\""
|
||
, fillAttr
|
||
, " stroke-linejoin=\"round\" stroke-linecap=\"round\"/>"
|
||
]
|
||
|
||
-- | One vertex point per present axis. Confidence axis gets a 3×3 square
|
||
-- instead of a 2-px circle when @confidence: proved@ is in effect — the
|
||
-- "proof cap" marker (MARKS.md §4.3).
|
||
renderVertexMarks :: EpistemicData -> T.Text
|
||
renderVertexMarks d = T.concat $ catMaybes
|
||
[ vertexMark d i | i <- [0..5] ]
|
||
|
||
vertexMark :: EpistemicData -> Int -> Maybe T.Text
|
||
vertexMark d i = do
|
||
v <- axisValue d i
|
||
let (x, y) = polar (axisAngles !! i) (fxAxisFull * v)
|
||
squareCap = i == 0 && epConfidenceProved d
|
||
return $ if squareCap
|
||
then T.concat
|
||
[ "<rect x=\"", ff (x - 1.5), "\" y=\"", ff (y - 1.5)
|
||
, "\" width=\"3\" height=\"3\""
|
||
, " fill=\"currentColor\" stroke=\"none\"/>"
|
||
]
|
||
else T.concat
|
||
[ "<circle cx=\"", ff x, "\" cy=\"", ff y
|
||
, "\" r=\"2\" fill=\"currentColor\" stroke=\"none\"/>"
|
||
]
|
||
|
||
-- | Outer-ring stability ticks at the top of the figure. Always five
|
||
-- positions; inactive ticks render at opacity 0.4 so the full scale
|
||
-- stays visible. Peer-status modulates tick *style*; see
|
||
-- 'renderPeerStatusOverlay'.
|
||
renderTicks :: String -> Maybe String -> T.Text
|
||
renderTicks stability peerStatus =
|
||
let activeCount = case stability of
|
||
"volatile" -> 1
|
||
"revising" -> 2
|
||
"fairly stable" -> 3
|
||
"stable" -> 4
|
||
"established" -> 5
|
||
_ -> 1
|
||
tickAngles :: [Double]
|
||
tickAngles = [0, -15, 15, -30, 30]
|
||
tickOne :: Int -> Double -> T.Text
|
||
tickOne idx a =
|
||
let (x1, y1) = polar a fxOuterPlus
|
||
(x2, y2) = polar a (fxOuterPlus + 1.5)
|
||
op = if idx < activeCount then "1.0" else "0.4"
|
||
in T.concat
|
||
[ "<line x1=\"", ff x1, "\" y1=\"", ff y1
|
||
, "\" x2=\"", ff x2, "\" y2=\"", ff y2
|
||
, "\" stroke=\"currentColor\" stroke-width=\"1\""
|
||
, " stroke-linecap=\"round\" opacity=\"", op, "\"/>"
|
||
]
|
||
in T.concat (zipWith tickOne [0..] tickAngles)
|
||
<> renderPeerStatusOverlay peerStatus
|
||
|
||
-- | Per-peer-status decorations layered on top of the tick group.
|
||
-- Geometry per MARKS.md §4.1.
|
||
renderPeerStatusOverlay :: Maybe String -> T.Text
|
||
renderPeerStatusOverlay Nothing = ""
|
||
renderPeerStatusOverlay (Just "under-review") =
|
||
-- Small unfilled circle just outside the outermost tick, at the top.
|
||
let (x, y) = polar 0 (fxOuterPlus + 3.5)
|
||
in T.concat
|
||
[ "<circle cx=\"", ff x, "\" cy=\"", ff y
|
||
, "\" r=\"1\" fill=\"none\" stroke=\"currentColor\""
|
||
, " stroke-width=\"0.6\"/>"
|
||
]
|
||
renderPeerStatusOverlay (Just "peer-reviewed") =
|
||
-- Single horizontal bar above the outer roundel arc, centred on top.
|
||
T.concat
|
||
[ "<line x1=\"", ff (fxCenter - 6), "\" y1=\"", ff (fyCenter - fxOuterPlus - 3)
|
||
, "\" x2=\"", ff (fxCenter + 6), "\" y2=\"", ff (fyCenter - fxOuterPlus - 3)
|
||
, "\" stroke=\"currentColor\" stroke-width=\"0.7\""
|
||
, " stroke-linecap=\"round\"/>"
|
||
]
|
||
renderPeerStatusOverlay (Just "published") =
|
||
-- Printer's-bracket: short vertical marks at ±15° on the outer roundel.
|
||
let (lx1, ly1) = polar (-15) (fxOuterPlus + 1)
|
||
(lx2, ly2) = polar (-15) (fxOuterPlus + 4)
|
||
(rx1, ry1) = polar 15 (fxOuterPlus + 1)
|
||
(rx2, ry2) = polar 15 (fxOuterPlus + 4)
|
||
in T.concat
|
||
[ "<line x1=\"", ff lx1, "\" y1=\"", ff ly1
|
||
, "\" x2=\"", ff lx2, "\" y2=\"", ff ly2
|
||
, "\" stroke=\"currentColor\" stroke-width=\"0.8\""
|
||
, " stroke-linecap=\"round\"/>"
|
||
, "<line x1=\"", ff rx1, "\" y1=\"", ff ry1
|
||
, "\" x2=\"", ff rx2, "\" y2=\"", ff ry2
|
||
, "\" stroke=\"currentColor\" stroke-width=\"0.8\""
|
||
, " stroke-linecap=\"round\"/>"
|
||
]
|
||
renderPeerStatusOverlay (Just "retracted") =
|
||
-- Horizontal strikethrough across the tick group.
|
||
T.concat
|
||
[ "<line x1=\"", ff (fxCenter - 9), "\" y1=\"", ff (fyCenter - fxOuterPlus - 1)
|
||
, "\" x2=\"", ff (fxCenter + 9), "\" y2=\"", ff (fyCenter - fxOuterPlus - 1)
|
||
, "\" stroke=\"currentColor\" stroke-width=\"1.5\""
|
||
, " stroke-linecap=\"round\"/>"
|
||
]
|
||
renderPeerStatusOverlay (Just _) = ""
|
||
|
||
-- | Trust score (Spectral, 16 px) and the small "TRUST" label below it.
|
||
renderTrustLabel :: Int -> T.Text
|
||
renderTrustLabel score = T.concat
|
||
[ "<text x=\"", ff fxCenter, "\" y=\"", ff (fyCenter + 4)
|
||
, "\" text-anchor=\"middle\""
|
||
, " fill=\"currentColor\" stroke=\"none\""
|
||
, " font-family=\"Spectral, serif\" font-weight=\"500\" font-size=\"16\">"
|
||
, T.pack (show score)
|
||
, "</text>"
|
||
, "<text x=\"", ff fxCenter, "\" y=\"", ff (fyCenter + 14)
|
||
, "\" text-anchor=\"middle\""
|
||
, " fill=\"currentColor\" stroke=\"none\""
|
||
, " font-family=\""Fira Sans", sans-serif\""
|
||
, " font-size=\"5\" letter-spacing=\"0.18em\""
|
||
, " opacity=\"0.7\">TRUST</text>"
|
||
]
|
||
|
||
-- | Result-shape glyph immediately to the right of the trust score.
|
||
renderResultShape :: Maybe String -> Int -> T.Text
|
||
renderResultShape Nothing _ = ""
|
||
renderResultShape (Just shape) score =
|
||
let glyph = case shape of
|
||
"positive" -> "+"
|
||
"negative" -> "\x2212" -- minus sign (not hyphen-minus)
|
||
"mixed" -> "\x00B1" -- ±
|
||
"comparative" -> "\x223C" -- ∼
|
||
"descriptive" -> "\x25A1" -- □
|
||
_ -> ""
|
||
-- Offset proportional to the trust number's width (digits ≈ 8 px each).
|
||
digitCount = length (show score)
|
||
offset = fromIntegral digitCount * 4.5 + 3 :: Double
|
||
in if T.null (T.pack glyph)
|
||
then ""
|
||
else T.concat
|
||
[ "<text x=\"", ff (fxCenter + offset)
|
||
, "\" y=\"", ff (fyCenter + 4)
|
||
, "\" text-anchor=\"start\""
|
||
, " fill=\"currentColor\" stroke=\"none\""
|
||
, " font-family=\"Spectral, serif\" font-size=\"16\">"
|
||
, T.pack glyph
|
||
, "</text>"
|
||
]
|
||
|
||
-- ---------------------------------------------------------------------------
|
||
-- Field exports
|
||
-- ---------------------------------------------------------------------------
|
||
|
||
-- | @$epistemicSvg$@. Returns 'noResult' when @status:@ is absent
|
||
-- (matches the existing visibility rule for the epistemic block —
|
||
-- MARKS.md §3.1). Otherwise returns the inline SVG string ready for
|
||
-- template interpolation.
|
||
epistemicSvgField :: Context String
|
||
epistemicSvgField = field "epistemicSvg" $ \item -> do
|
||
meta <- getMetadata (itemIdentifier item)
|
||
case lookupString "status" meta of
|
||
Nothing -> noResult "no status; epistemic figure suppressed"
|
||
Just _ -> do
|
||
d <- readEpistemicData item
|
||
return $ T.unpack (wrapEpistemic (renderEpistemicFigure d))
|
||
|
||
wrapEpistemic :: T.Text -> T.Text
|
||
wrapEpistemic svg = T.concat
|
||
[ "<figure class=\"frontmatter-mark frontmatter-mark--epistemic\">"
|
||
, svg
|
||
, "</figure>"
|
||
]
|
||
|