hgg-svg-0.2.0.0: src/Graphics/Hgg/Backend/SVG.hs
-- |
-- Module : Graphics.Hgg.Backend.SVG
-- Description : SVG backend (with Resolver support)
-- Copyright : (c) 2026 Aelysce Project (Toshiaki Honda)
-- License : BSD-3-Clause
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Hgg.Backend.SVG
( -- * 通常 (Resolver 不要 = inline 列のみの図)
renderSVG
, saveSVG
-- * Resolver 同伴 (= @ColByName@ を含む図)
, renderSVGWith
, saveSVGWith
, renderSVGInteractive
, saveSVGInteractive
, plot
-- * Phase 14: BoundPlot (df バインド済) を描画する
, renderBound
, saveSVGBound
-- * Phase 3 A8: Primitive 列を直接 SVG にする helper (= hgg-3d 用)
, renderPrimitivesSVG
, savePrimitivesSVG
) where
import Graphics.Hgg.Frame (BoundPlot (..))
import Graphics.Hgg.Layout (Layout (..), Rect (..),
ViewportSize (..), computeLayout)
import Graphics.Hgg.Render (FillStyle (..), LineStyle (..),
PathSegment (..), Point (..),
Primitive (..), StrokeStyle (..),
TextAnchor (..), TextStyle (..),
renderToPrimitives, scalePrimitives)
import Graphics.Hgg.Spec (MarkKind (..), Resolver, VisualSpec (..),
emptyResolver, lyKind, vsDpi)
import Data.Monoid (getFirst, getLast)
import Graphics.Hgg.Validate (PlotDiagnostic, Severity (..),
diagnosticSeverity, renderDiagnostic,
reportFacetInlineWarnings,
reportTernaryMarkWarnings)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import System.IO (hPutStrLn, stderr)
-- | [日本語]: 'Resolver' を渡して 'VisualSpec' を SVG text に。 @ColByName@ を含む図用。
-- [English]: Renders a 'VisualSpec' to SVG text given a 'Resolver'. For
-- figures that include @ColByName@.
renderSVGWith :: Resolver -> VisualSpec -> Text
renderSVGWith r spec =
let layout = computeLayout r spec
-- ★ Phase 33 B5: layout/primitive は純 pt。SVG (raster 想定) は dpi/72 を
-- 一度だけ掛けて device px へ (唯一の dpi 適用点)。既定 96dpi → k=4/3。
k = maybe 96 id (getLast (vsDpi spec)) / 72
primitives = scalePrimitives k (renderToPrimitives r layout spec)
ViewportSize wpt hpt = lpViewport layout
w = round (fromIntegral wpt * k) :: Int
h = round (fromIntegral hpt * k) :: Int
header = T.concat
[ "<svg xmlns=\"http://www.w3.org/2000/svg\" "
, "width=\"", num w, "\" "
, "height=\"", num h, "\" "
, "viewBox=\"0 0 ", num w, " ", num h, "\">"
]
in T.concat (header : primsToSvg primitives : ["</svg>"])
-- | [日本語]: render 'VisualSpec' to SVG text。 Resolver 不要 (= 全 ColRef が inline、
-- @ColByName@ が無い図で使う、 = 通常)。 列名参照を含む図は 'renderSVGWith'。
-- [English]: Renders a 'VisualSpec' to SVG text. No 'Resolver' needed (used
-- for figures where every @ColRef@ is inline and there is no @ColByName@ —
-- the usual case). For figures with column-name references, use
-- 'renderSVGWith'.
renderSVG :: VisualSpec -> Text
renderSVG = renderSVGWith emptyResolver
-- | [日本語]: 'Resolver' を渡して SVG ファイルに保存。 @ColByName@ を含む図用。
-- [English]: Saves to an SVG file given a 'Resolver'. For figures that
-- include @ColByName@.
saveSVGWith :: FilePath -> Resolver -> VisualSpec -> IO ()
saveSVGWith path r spec = do
reportFacetInlineWarnings r spec -- ★ Phase 62 A4 (§3): 描画は継続
reportTernaryMarkWarnings r spec -- Phase 64 A13: coordTernary unsupported mark
TIO.writeFile path (renderSVGWith r spec)
-- | [日本語]: SVG ファイルに保存。 Resolver 不要 (= inline 列のみの図、 = 通常)。
-- 列名参照を含む図は 'saveSVGWith'、 DataFrame は 'saveSVGBound' (@df |>> spec@)。
-- [English]: Saves to an SVG file. No 'Resolver' needed (figures with
-- inline columns only — the usual case). For figures with column-name
-- references use 'saveSVGWith'; for a DataFrame use 'saveSVGBound'
-- (@df |>> spec@).
saveSVG :: FilePath -> VisualSpec -> IO ()
saveSVG path = saveSVGWith path emptyResolver
-- | [日本語]: @purePlot@ (= 純粋値) と対をなす副作用関数。 中身は 'saveSVG' の alias、
-- SVG backend が default。 他 backend (PDF / PNG) を使う場合はそれぞれの
-- module の `plot` を import する。
-- [English]: The effectful counterpart of @purePlot@ (the pure value).
-- Internally just an alias of 'saveSVG', with the SVG backend as default.
-- To use another backend (PDF / PNG), import `plot` from the corresponding
-- module instead.
--
-- > main = plot "out.svg" $ purePlot <> layer (scatter ...) <> title "..."
plot :: FilePath -> VisualSpec -> IO ()
plot = saveSVG
-- | [日本語]: 'BoundPlot' (= @df |>> spec@ の結果) を SVG text に。
-- 'renderSVGWith' を 'bpResolver' / 'bpSpec' で呼ぶ薄いラッパ。
-- 検証診断 ('bpDiagnostics') は副作用が無いここでは無視する
-- (報告は 'saveSVGBound' / 利用者が 'bpDiagnostics' を直接見る)。
-- [English]: Renders a 'BoundPlot' (the result of @df |>> spec@) to SVG
-- text. A thin wrapper that calls 'renderSVGWith' with 'bpResolver' /
-- 'bpSpec'. The validation diagnostics ('bpDiagnostics') are ignored here
-- since this function has no side effects (reporting is left to
-- 'saveSVGBound' or to the caller inspecting 'bpDiagnostics' directly).
renderBound :: BoundPlot -> Text
renderBound (BoundPlot r spec _) = renderSVGWith r spec
-- | [日本語]: 'BoundPlot' を SVG ファイルに保存。
-- 'bpDiagnostics' に Error severity があれば __stderr に報告__してから書き出す
-- (描画自体は止めない = 純値 @(|>>)@ の lenient 既定。 無検証で通したい場合は
-- @unBound@ → 'saveSVGWith' を直接使う)。
-- [English]: Saves a 'BoundPlot' to an SVG file. If 'bpDiagnostics'
-- contains an error-severity entry, __reports it to stderr__ before
-- writing the file (rendering itself is not stopped — the lenient default
-- of the pure @(|>>)@. To skip validation entirely, use @unBound@ followed
-- by 'saveSVGWith' directly).
saveSVGBound :: FilePath -> BoundPlot -> IO ()
saveSVGBound path bp@(BoundPlot _ spec diags) = do
reportErrors diags
warnUnresolvedStats spec
TIO.writeFile path (renderBound bp)
-- | [日本語]: footgun 緩和: spec に未解決 stat layer (@MStatLM@/@MStatSmooth@) が残っていたら
-- stderr に警告 (描画では skip され回帰線が出ない)。 回帰を描くには analyze-bridge の
-- @saveSVGBoundStats@ / @resolveStats@ を使う。 stat を使わない通常図では何もしない。
-- [English]: A footgun guard: if the spec still has an unresolved stat
-- layer (@MStatLM@/@MStatSmooth@), warns on stderr (rendering skips it, so
-- no regression line is drawn). To draw the regression, use
-- analyze-bridge's @saveSVGBoundStats@ / @resolveStats@. Does nothing for
-- ordinary figures that do not use a stat layer.
warnUnresolvedStats :: VisualSpec -> IO ()
warnUnresolvedStats spec
| any isStat (vsLayers spec) =
hPutStrLn stderr
"[hgg] 警告: 未解決の stat layer (statLm/statSmooth) があります。 \
\回帰線は描画されません。 analyze-bridge の saveSVGBoundStats で描画してください。"
| otherwise = pure ()
where
isStat ly = case getFirst (lyKind ly) of
Just MStatLM -> True
Just MStatSmooth -> True
_ -> False
-- | [日本語]: Error severity の診断のみ stderr に出す。
-- [English]: Emits only the error-severity diagnostics to stderr.
reportErrors :: [PlotDiagnostic] -> IO ()
reportErrors diags =
mapM_ (hPutStrLn stderr . T.unpack . renderDiagnostic)
(filter ((== SevError) . diagnosticSeverity) diags)
-- | [日本語]: Interactive 版: hover tooltip (= 標準 native) に加えて、
-- ドラッグで pan / wheel で zoom できる inline JS を末尾に embed。
-- ブラウザで開いた時だけ動作、 raw SVG viewer では普通に静止画。
-- [English]: The interactive variant: in addition to the standard native
-- hover tooltip, embeds inline JS at the end that enables drag-to-pan and
-- wheel-to-zoom. This only works when opened in a browser; in a raw SVG
-- viewer it is just a static image.
renderSVGInteractive :: Resolver -> VisualSpec -> Text
renderSVGInteractive r spec =
let base = renderSVGWith r spec
-- </svg> 直前に <script> を挿入
(pre, post) = T.breakOn "</svg>" base
in T.concat [pre, panZoomScript, post]
saveSVGInteractive :: FilePath -> Resolver -> VisualSpec -> IO ()
saveSVGInteractive path r spec = do
reportFacetInlineWarnings r spec -- ★ Phase 62 A4 (§3)
reportTernaryMarkWarnings r spec -- Phase 64 A13: coordTernary unsupported mark
TIO.writeFile path (renderSVGInteractive r spec)
-- | [日本語]: '[Primitive]' を直接 SVG にする helper。
-- 'renderSVG' は VisualSpec 経由だが、 hgg-3d のように外部で
-- Primitive 列を生成済の場合に使う。 既存の 'primToSvg' converter をそのまま流用、
-- 出力 SVG 構造 (= header + light bg + title + body) は 'renderSVG' と同形式。
-- [English]: A helper that turns a '[Primitive]' directly into SVG. While
-- 'renderSVG' goes through a VisualSpec, this is for cases where the
-- primitives have already been generated externally, as in
-- hgg-3d. Reuses the existing 'primToSvg' converter as-is, so the
-- output SVG structure (header + light bg + title + body) matches
-- 'renderSVG'.
renderPrimitivesSVG :: Int -> Int -> Text -> [Primitive] -> Text
renderPrimitivesSVG w h titleTxt prims =
let header = T.concat
[ "<svg xmlns=\"http://www.w3.org/2000/svg\" "
, "width=\"", num w, "\" "
, "height=\"", num h, "\" "
, "viewBox=\"0 0 ", num w, " ", num h, "\">"
]
-- bg + title
bg = T.concat
[ "<rect x=\"0\" y=\"0\" width=\"", num w
, "\" height=\"", num h
, "\" fill=\"#fafafa\"/>" ]
-- ★ Phase 43 既定に合わせタイトルは左寄せ (ggplot theme_grey)。 3D backend は
-- plotArea を持たないので左 margin は固定 20px。 2D の plot.title 左寄せと統一。
title_ = if T.null titleTxt then "" else T.concat
[ "<text x=\"20\" y=\"30\""
, " text-anchor=\"start\" font-family=\"sans-serif\""
, " font-size=\"16\" fill=\"#333\">", titleTxt, "</text>" ]
in T.concat (header : bg : title_ : primsToSvg prims : ["</svg>"])
-- | [日本語]: 'renderPrimitivesSVG' をファイル書出し版。
-- [English]: The file-writing variant of 'renderPrimitivesSVG'.
savePrimitivesSVG :: FilePath -> Int -> Int -> Text -> [Primitive] -> IO ()
savePrimitivesSVG path w h t prims =
TIO.writeFile path (renderPrimitivesSVG w h t prims)
-- | [日本語]: pan / zoom inline JS。 SVG の viewBox を操作するだけの最小実装。
-- [English]: The pan / zoom inline JS. A minimal implementation that only
-- manipulates the SVG's viewBox.
panZoomScript :: Text
panZoomScript = T.concat
[ "<script type=\"application/ecmascript\"><![CDATA[\n"
, "(function(){\n"
, " var svg = document.currentScript.parentNode;\n"
, " var vb = svg.viewBox.baseVal;\n"
, " var dragging = false, sx = 0, sy = 0, vx0 = 0, vy0 = 0;\n"
, " svg.addEventListener('mousedown', function(e){\n"
, " dragging = true; sx = e.clientX; sy = e.clientY;\n"
, " vx0 = vb.x; vy0 = vb.y;\n"
, " svg.style.cursor = 'grabbing';\n"
, " });\n"
, " window.addEventListener('mouseup', function(){\n"
, " dragging = false; svg.style.cursor = 'default';\n"
, " });\n"
, " svg.addEventListener('mousemove', function(e){\n"
, " if (!dragging) return;\n"
, " var dx = (e.clientX - sx) * vb.width / svg.clientWidth;\n"
, " var dy = (e.clientY - sy) * vb.height / svg.clientHeight;\n"
, " vb.x = vx0 - dx; vb.y = vy0 - dy;\n"
, " });\n"
, " svg.addEventListener('wheel', function(e){\n"
, " e.preventDefault();\n"
, " var scale = e.deltaY > 0 ? 1.1 : 1/1.1;\n"
, " var rect = svg.getBoundingClientRect();\n"
, " var mx = vb.x + (e.clientX - rect.left) * vb.width / rect.width;\n"
, " var my = vb.y + (e.clientY - rect.top) * vb.height / rect.height;\n"
, " vb.x = mx - (mx - vb.x) * scale;\n"
, " vb.y = my - (my - vb.y) * scale;\n"
, " vb.width *= scale; vb.height *= scale;\n"
, " });\n"
, "})();\n"
, "]]></script>"
]
-- ---------------------------------------------------------------------------
-- Primitive → SVG element
-- ---------------------------------------------------------------------------
-- | [日本語]: clip stack を解決して SVG body に変換。 'PClipPush' で
-- @\<clipPath\>@ + @\<g clip-path\>@ を開き、 'PClipPop' で @\</g\>@ を閉じる。
-- clip プリミティブが無い列では @map primToSvg@ と完全同一出力なので既存 SVG ゼロ diff。
-- [English]: Resolves the clip stack and converts it to SVG body. Opens
-- @\<clipPath\>@ + @\<g clip-path\>@ at 'PClipPush', and closes @\</g\>@ at
-- 'PClipPop'. For a primitive list with no clip primitives, the output is
-- byte-identical to @map primToSvg@, so it produces zero diff against
-- existing SVG output.
primsToSvg :: [Primitive] -> Text
primsToSvg = T.concat . go (0 :: Int)
where
go _ [] = []
go n (PClipPush (Rect x y w h) : rest) =
let cid = T.concat ["clip", num n]
open = T.concat
[ "<clipPath id=\"", cid, "\"><rect x=\"", numD x, "\" y=\"", numD y
, "\" width=\"", numD w, "\" height=\"", numD h, "\"/></clipPath>"
, "<g clip-path=\"url(#", cid, ")\">" ]
in open : go (n + 1) rest
-- Phase 64 §2: 多角形 clip。 <polygon> は暗黙に閉じるので points をそのまま出す。
-- 3 点未満は clip 無し (= <g> だけ開く) — Primitive の fail-open 規約。
go n (PClipPath pts : rest)
| length pts < 3 = "<g>" : go n rest
| otherwise =
let cid = T.concat ["clip", num n]
open = T.concat
[ "<clipPath id=\"", cid, "\"><polygon points=\""
, T.intercalate " " [T.concat [numD x, ",", numD y] | Point x y <- pts]
, "\"/></clipPath>"
, "<g clip-path=\"url(#", cid, ")\">" ]
in open : go (n + 1) rest
go n (PClipPop : rest) = "</g>" : go n rest
go n (p : rest) = primToSvg p : go n rest
primToSvg :: Primitive -> Text
primToSvg p = case p of
PLine (Point x1 y1) (Point x2 y2) (LineStyle c w d) ->
T.concat
[ "<line x1=\"", numD x1, "\" y1=\"", numD y1
, "\" x2=\"", numD x2, "\" y2=\"", numD y2
, "\" stroke=\"", c, "\" stroke-width=\"", numD w, "\""
, dashAttr d, "/>"
]
PRect (Rect x y w h) (FillStyle fc fo) mStroke ->
T.concat
[ "<rect x=\"", numD x, "\" y=\"", numD y
, "\" width=\"", numD w, "\" height=\"", numD h
, "\" fill=\"", fc, "\" fill-opacity=\"", numD fo, "\""
, strokeAttr mStroke
, "/>"
]
PCircle (Point cx cy) r (FillStyle fc fo) mStroke mTitle ->
case mTitle of
Nothing ->
T.concat
[ "<circle cx=\"", numD cx, "\" cy=\"", numD cy
, "\" r=\"", numD r
, "\" fill=\"", fc, "\" fill-opacity=\"", numD fo, "\""
, strokeAttr mStroke
, "/>"
]
Just t ->
-- <circle><title>label</title></circle> でブラウザ native hover tooltip
T.concat
[ "<circle cx=\"", numD cx, "\" cy=\"", numD cy
, "\" r=\"", numD r
, "\" fill=\"", fc, "\" fill-opacity=\"", numD fo, "\""
, strokeAttr mStroke
, "><title>", escapeXml t, "</title></circle>"
]
PText (Point x y) s (TextStyle c sz fam anchor rot weight italic) ->
let anchorAttr = case anchor of
AnchorStart -> "start"
AnchorMiddle -> "middle"
AnchorEnd -> "end"
-- Phase 50 A1: 内部 'tsRotate' は **CCW 正** (canonical)。 SVG rotate() は y-down で
-- CW 正なので、 ここで **符号反転** して device の CW へ変換する (唯一の変換点)。
rotAttr = if rot == 0
then ""
else T.concat [" transform=\"rotate(", numD (negate rot)
, " ", numD x, " ", numD y, ")\""]
-- TODO-10 (2026-05-29): font-weight / font-style emit (default 値は省略)
weightAttr = if weight == "normal" || T.null weight
then ""
else T.concat [" font-weight=\"", weight, "\""]
italicAttr = if italic then " font-style=\"italic\"" else ""
in T.concat
[ "<text x=\"", numD x, "\" y=\"", numD y
, "\" fill=\"", c, "\" font-size=\"", numD sz
, "\" font-family=\"", fam
, "\" text-anchor=\"", anchorAttr, "\""
, weightAttr, italicAttr
, rotAttr
, ">"
, escapeXml s
, "</text>"
]
PPath segs (FillStyle fc fo) mStroke ->
T.concat
[ "<path d=\"", pathSegs segs
, "\" fill=\"", fc, "\" fill-opacity=\"", numD fo, "\""
, strokeAttr mStroke
, "/>"
]
PClipPush{} -> ""
PClipPath{} -> ""
PClipPop -> ""
PTransformPush{} -> ""
PTransformPop -> ""
pathSegs :: [PathSegment] -> Text
pathSegs = T.intercalate " " . map seg
where
seg (MoveTo (Point x y)) = T.concat ["M ", numD x, " ", numD y]
seg (LineTo (Point x y)) = T.concat ["L ", numD x, " ", numD y]
seg (CurveTo (Point cx1 cy1) (Point cx2 cy2) (Point x y)) = T.concat
["C ", numD cx1, " ", numD cy1, " ", numD cx2, " ", numD cy2, " ", numD x, " ", numD y]
seg ClosePath = "Z"
strokeAttr :: Maybe StrokeStyle -> Text
strokeAttr Nothing = " stroke=\"none\""
strokeAttr (Just (StrokeStyle c w)) =
T.concat [" stroke=\"", c, "\" stroke-width=\"", numD w, "\""]
-- | [日本語]: stroke-dasharray 属性。 空配列 (= 実線) は attr を出さない
-- (= 既存 SVG ゼロ diff の要)。 非空のみ \" stroke-dasharray=\\\"a,b,..\\\"\" を付す。
-- [English]: The stroke-dasharray attribute. An empty array (a solid line)
-- emits no attribute (needed for zero diff against existing SVG). Only for
-- a non-empty list does it emit \" stroke-dasharray=\\\"a,b,..\\\"\".
dashAttr :: [Double] -> Text
dashAttr [] = ""
dashAttr ds = T.concat [" stroke-dasharray=\"", T.intercalate "," (map numD ds), "\""]
num :: Int -> Text
num = T.pack . show
numD :: Double -> Text
numD = T.pack . show
escapeXml :: Text -> Text
escapeXml = T.concatMap esc
where
esc '<' = "<"
esc '>' = ">"
esc '&' = "&"
esc '"' = """
esc '\'' = "'"
esc c = T.singleton c