{-# 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 @@, -- and wraps the result in @
@. 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 [ "
" , svg , "
" ] -- | Replace hardcoded black fills/strokes with @currentColor@ and strip -- the root @@'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 @@. -- 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 [ "" , renderRoundel , renderGuides , renderAxes , renderPolygon d , renderVertexMarks d , renderTicks (epStability d) (epPeerStatus d) , renderTrustLabel (epTrust d) , renderResultShape (epResultShape d) (epTrust d) , "" ] -- | Two thin concentric circles forming the outer roundel. renderRoundel :: T.Text renderRoundel = T.concat [ "" , "" ] -- | 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 [ "" ] -- | 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 [ "" ] -- | 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 [ "" ] else T.concat [ "" ] -- | 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 [ "" ] 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 [ "" ] renderPeerStatusOverlay (Just "peer-reviewed") = -- Single horizontal bar above the outer roundel arc, centred on top. T.concat [ "" ] 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 [ "" , "" ] renderPeerStatusOverlay (Just "retracted") = -- Horizontal strikethrough across the tick group. T.concat [ "" ] renderPeerStatusOverlay (Just _) = "" -- | Trust score (Spectral, 16 px) and the small "TRUST" label below it. renderTrustLabel :: Int -> T.Text renderTrustLabel score = T.concat [ "" , T.pack (show score) , "" , "TRUST" ] -- | 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 [ "" , T.pack glyph , "" ] -- --------------------------------------------------------------------------- -- 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 [ "
" , svg , "
" ]