{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -- | Conversion between 'ChartOptions' and 'Markup' representations. module Chart.Markup ( Markup (..), ChartOptions (..), forgetHud, markupChartOptions, markupChartTree, markupChart, header, renderChartOptions, encodeChartOptions, writeChartOptions, CssOptions (..), defaultCssOptions, PreferColorScheme (..), cssPreferColorScheme, fillSwitch, ShapeRendering (..), markupCssOptions, MarkupOptions (..), defaultMarkupOptions, encodeNum, encodePx, defaultCssFontFamilies, ) where import Chart.Data import Chart.Hud import Chart.Primitive hiding (tree) import Chart.Style import Data.Bool import Data.ByteString (ByteString, intercalate, writeFile) import Data.Colour import Data.FormatN import Data.Maybe import Data.Path import Data.Path.Parser import Data.String.Interpolate import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics import MarkupParse import NumHask.Space import Optics.Core hiding (element) import Prelude -- $setup -- -- >>> :set -XOverloadedLabels -- >>> :set -XOverloadedStrings -- >>> import Chart -- >>> import Optics.Core -- >>> let c0 = ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty -- >>> import Chart.Examples -- >>> import MarkupParse -- | Show a Double, or rounded to 4 decimal places if this is shorter. -- -- >>> encodeNum 1 -- "1.0" -- -- >>> encodeNum 1.23456 -- "1.2346" encodeNum :: Double -> ByteString encodeNum = encodeUtf8 . formatOrShow (FixedStyle 4) Nothing -- | SVG width and height, without any unit suffix, are defined as pixels, which are Integers -- -- >>> encodePx 300.0 -- "300" encodePx :: Double -> ByteString encodePx = strToUtf8 . show . (floor :: Double -> Int) -- | Convert a ChartTree to markup -- -- >>> lineExample & view #chartTree & markupChartTree & markdown_ Compact Xml -- "" markupChartTree :: ChartTree -> Markup markupChartTree cs = maybe xs' (\l -> element "g" [Attr "class" (encodeUtf8 l)] xs') label where (ChartTree (Node (label, cs') xs)) = filterChartTree (not . isEmptyChart . chartData) cs xs' = mconcat $ fmap markupChart cs' <> (markupChartTree . ChartTree <$> xs) markupText :: Style -> Text -> Point Double -> Markup markupText s t p@(Point x y) = frame' <> element "text" as (bool (contentRaw c) (content c) (EscapeText == view #escapeText s)) where as = uncurry Attr <$> [ ("x", encodeNum x), ("y", encodeNum $ -y) ] <> maybeToList ((\x' -> ("transform", toRotateText x' p)) <$> view #rotation s) -- This is very late for a chart creation. It is here so that the chart doesn't undergo scaling and thus picks up the local size of the text, less the border size of the frame. frame' = case view #frame s of Nothing -> Markup mempty Just f -> markupChart (Chart (f & over #borderSize (* view #size s)) (RectData [styleBoxText (s & set #frame Nothing) t p])) c = encodeUtf8 t -- | Markup a text rotation about a point in radians. -- -- includes reference changes: -- -- - from radians to degrees -- -- - from counter-clockwise is a positive rotation to clockwise is positive -- -- - flip y dimension toRotateText :: Double -> Point Double -> ByteString toRotateText r (Point x y) = "rotate(" <> encodeNum (-(r * 180 / pi)) <> ", " <> encodeNum x <> ", " <> encodeNum (-y) <> ")" toScaleText :: Double -> ByteString toScaleText x = "scale(" <> encodeNum x <> ")" -- | Convert a Rect to Markup markupRect :: Rect Double -> Markup markupRect (Rect x z y w) = emptyElem "rect" as where as = uncurry Attr <$> [ ("width", encodeNum (z - x)), ("height", encodeNum (w - y)), ("x", encodeNum x), ("y", encodeNum (-w)) ] -- | Convert a Chart to Markup -- -- >>> import MarkupParse -- >>> import Optics.Core -- >>> import Control.Category ((>>>)) -- >>> lineExample & toListOf (#chartTree % charts') & mconcat & fmap (markupChart >>> markdown_ Compact Xml) -- ["","",""] markupChart :: Chart -> Markup markupChart = uncurry (element "g") . f where f (Chart s (RectData xs)) = (attsRect s, mconcat (markupRect <$> xs)) f (Chart s (TextData xs)) = (attsText s, mconcat (uncurry (markupText s) <$> xs)) f (Chart s (GlyphData xs)) = (attsGlyph s, mconcat (markupGlyph s <$> xs)) f (Chart s (PathData xs)) = (attsPath s, markupPath xs) f (Chart s (LineData xs)) = (attsLine s, markupLine xs) f (Chart _ (BlankData _)) = ([], mempty) markupLine :: [[Point Double]] -> Markup markupLine lss = mconcat $ emptyElem "polyline" . (: []) . Attr "points" . toPointsText <$> lss toPointsText :: [Point Double] -> ByteString toPointsText xs = intercalate " " $ (\(Point x y) -> encodeNum x <> "," <> encodeNum (-y)) <$> xs -- | Path markup markupPath :: [PathData Double] -> Markup markupPath ps = emptyElem "path" [Attr "d" (pathDataToSvg ps)] -- | GlyphStyle to markup Tree -- Note rotation on the outside not the inside. markupGlyph :: Style -> Point Double -> Markup markupGlyph s p = case view #rotation s of Nothing -> gl Just r -> element "g" [Attr "transform" (toRotateText r p)] gl where gl = markupShape_ (view #glyphShape s) (view #size s) p -- | Convert a dash representation from a list to text fromDashArray :: [Double] -> ByteString fromDashArray xs = intercalate " " $ encodeNum <$> xs fromDashOffset :: Double -> ByteString fromDashOffset x = encodeNum x attsLine :: Style -> [Attr] attsLine o = uncurry Attr <$> [ ("stroke-width", encodeNum $ view #size o), ("stroke", showRGB $ view #color o), ("stroke-opacity", showOpacity $ view #color o), ("fill", "none") ] <> catMaybes [(\x -> ("stroke-linecap", fromLineCap x)) <$> view #lineCap o] <> foldMap (\x -> [("stroke-linejoin", fromLineJoin x)]) (view #lineJoin o) <> foldMap (\x -> [("stroke-dasharray", fromDashArray x)]) (view #dasharray o) <> foldMap (\x -> [("stroke-dashoffset", fromDashOffset x)]) (view #dashoffset o) attsRect :: Style -> [Attr] attsRect o = uncurry Attr <$> [ ("stroke-width", encodeNum $ view #borderSize o), ("stroke", showRGB $ view #borderColor o), ("stroke-opacity", showOpacity $ view #borderColor o), ("fill", showRGB $ view #color o), ("fill-opacity", showOpacity $ view #color o) ] -- | TextStyle to [Attr] attsText :: Style -> [Attr] attsText o = uncurry Attr <$> [ ("stroke-width", "0.0"), ("stroke", "none"), ("fill", showRGB $ view #color o), ("fill-opacity", showOpacity $ view #color o), ("font-size", encodeNum $ view #size o), ("text-anchor", toTextAnchor $ view #anchor o) ] where toTextAnchor :: Anchor -> ByteString toTextAnchor AnchorMiddle = "middle" toTextAnchor AnchorStart = "start" toTextAnchor AnchorEnd = "end" -- | GlyphStyle to [Attr] attsGlyph :: Style -> [Attr] attsGlyph o = uncurry Attr <$> [ ("stroke-width", encodeNum $ view #borderSize o), ("stroke", showRGB $ view #borderColor o), ("stroke-opacity", showOpacity $ view #borderColor o), ("fill", showRGB $ view #color o), ("fill-opacity", showOpacity $ view #color o) ] <> foldMap ((: []) . (,) "transform" . toTranslateText) (view #translate o) -- | PathStyle to [Attr] attsPath :: Style -> [Attr] attsPath o = uncurry Attr <$> [ ("stroke-width", encodeNum $ view #borderSize o), ("stroke", showRGB $ view #borderColor o), ("stroke-opacity", showOpacity $ view #borderColor o), ("fill", showRGB $ view #color o), ("fill-opacity", showOpacity $ view #color o) ] -- | includes a flip of the y dimension. toTranslateText :: Point Double -> ByteString toTranslateText (Point x y) = "translate(" <> encodeNum x <> ", " <> encodeNum (-y) <> ")" -- | GlyphShape to markup Tree markupShape_ :: GlyphShape -> Double -> Point Double -> Markup markupShape_ CircleGlyph s (Point x y) = emptyElem "circle" as where as = uncurry Attr <$> [ ("cx", encodeNum x), ("cy", encodeNum $ -y), ("r", encodeNum $ 0.5 * s) ] markupShape_ SquareGlyph s p = markupRect (move p ((s *) <$> one :: Rect Double)) markupShape_ (RectSharpGlyph x') s p = markupRect (move p (scale (Point s (x' * s)) one :: Rect Double)) markupShape_ (RectRoundedGlyph x' rx ry) s p = emptyElem "rect" as where as = uncurry Attr <$> [ ("width", encodeNum $ z - x), ("height", encodeNum $ w - y), ("x", encodeNum x), ("y", encodeNum $ -w), ("rx", encodeNum rx), ("ry", encodeNum ry) ] (Rect x z y w) = move p (scale (Point s (x' * s)) one) markupShape_ (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = emptyElem "polygon" as where as = uncurry Attr <$> [ ("transform", toTranslateText p), ("points", encodeNum (s * xa) <> "," <> encodeNum (-(s * ya)) <> " " <> encodeNum (s * xb) <> "," <> encodeNum (-(s * yb)) <> " " <> encodeNum (s * xc) <> "," <> encodeNum (-(s * yc))) ] markupShape_ (EllipseGlyph x') s (Point x y) = emptyElem "ellipse" as where as = uncurry Attr <$> [ ("cx", (strToUtf8 . show) x), ("cy", (strToUtf8 . show) $ -y), ("rx", (strToUtf8 . show) $ 0.5 * s), ("ry", (strToUtf8 . show) $ 0.5 * s * x') ] markupShape_ VLineGlyph s (Point x y) = emptyElem "polyline" [Attr "points" $ encodeNum x <> "," <> encodeNum (-(y - s / 2)) <> "\n" <> encodeNum x <> "," <> encodeNum (-(y + s / 2))] markupShape_ HLineGlyph s (Point x y) = emptyElem "polyline" [Attr "points" $ encodeNum (x - s / 2) <> "," <> encodeNum (-y) <> "\n" <> encodeNum (x + s / 2) <> "," <> encodeNum (-y)] markupShape_ (PathGlyph path) s p = emptyElem "path" (uncurry Attr <$> [("d", path), ("transform", toTranslateText p <> " " <> toScaleText s)]) -- | Create the classic SVG element -- -- >>> header (Just 300) (Rect (-0.75) 0.75 (-0.5) 0.5) (element_ "foo" []) & markdown_ Compact Xml -- "" header :: Maybe Double -> Rect Double -> Markup -> Markup header markupheight viewbox content' = element "svg" ( uncurry Attr <$> ( [ ("xmlns", "http://www.w3.org/2000/svg"), ("xmlns:xlink", "http://www.w3.org/1999/xlink") ] <> widthAndHeight <> [ ("viewBox", encodeNum x <> " " <> encodeNum (-w) <> " " <> encodeNum (z - x) <> " " <> encodeNum (w - y)) ] ) ) content' where (Rect x z y w) = viewbox Point w' h = width viewbox widthAndHeight = case markupheight of Nothing -> [] Just h' -> [ ("width", encodePx w''), ("height", encodePx h') ] where w'' = h' / h * w' -- | CSS prefer-color-scheme text snippet -- -- >>> cssPreferColorScheme (light, dark) PreferHud -- "svg {\n color-scheme: light dark;\n}\n{\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(5%, 5%, 5%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(5%, 5%, 5%);\n }\n .legendBorder g {\n fill: rgb(94%, 94%, 94%);\n }\n}\n@media (prefers-color-scheme:dark) {\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(94%, 94%, 94%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(94%, 94%, 94%);\n }\n .legendBorder g {\n fill: rgb(5%, 5%, 5%);\n }\n}" cssPreferColorScheme :: (Colour, Colour) -> PreferColorScheme -> ByteString cssPreferColorScheme (cl, cd) PreferHud = [i|svg { color-scheme: light dark; } { .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text { fill: #{showRGB cd}; } .ticklines g, .tickglyph g, .legendBorder g { stroke: #{showRGB cd}; } .legendBorder g { fill: #{showRGB cl}; } } @media (prefers-color-scheme:dark) { .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text { fill: #{showRGB cl}; } .ticklines g, .tickglyph g, .legendBorder g { stroke: #{showRGB cl}; } .legendBorder g { fill: #{showRGB cd}; } }|] cssPreferColorScheme (cl, _) PreferLight = [i|svg { color-scheme: light dark; } @media (prefers-color-scheme:dark) { markup { background-color: #{showRGB cl}; } }|] cssPreferColorScheme (_, cd) PreferDark = [i|svg { color-scheme: light dark; } @media (prefers-color-scheme:light) { markup { background-color: #{showRGB cd}; } }|] cssPreferColorScheme _ PreferNormal = mempty -- | CSS snippet to switch between dark and light mode -- -- > fillSwitch (color1, color2) "dark" "stuff" -- -- ... will default to color1 for elements of the "stuff" class, but switch to color2 if "dark" mode is preferred by the user. fillSwitch :: (Colour, Colour) -> ByteString -> ByteString -> ByteString fillSwitch (colorNormal, colorPrefer) prefer item = [i| { .#{item} g { fill: #{showRGB colorNormal}; } } @media (prefers-color-scheme:#{prefer}) { .#{item} g { fill: #{showRGB colorPrefer}; } } |] -- | Markup options. -- -- >>> defaultMarkupOptions -- MarkupOptions {markupHeight = Just 300.0, chartAspect = FixedAspect 1.5, cssOptions = CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, fontFamilies = "\nsvg { font-family: system-ui,-apple-system,\"Segoe UI\",Roboto,\"Helvetica Neue\",Arial,\"Noto Sans\",\"Liberation Sans\",sans-serif,\"Apple Color Emoji\",\"Segoe UI Emoji\",\"Segoe UI Symbol\",\"Noto Color Emoji\";\n}\n\nticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,\"Liberation Mono\",\"Courier New\",monospace;\n}\n\n", cssExtra = ""}, renderStyle = Compact} data MarkupOptions = MarkupOptions { markupHeight :: Maybe Double, chartAspect :: ChartAspect, cssOptions :: CssOptions, renderStyle :: RenderStyle } deriving (Eq, Show, Generic) -- | The official markup options defaultMarkupOptions :: MarkupOptions defaultMarkupOptions = MarkupOptions (Just 300) (FixedAspect 1.5) defaultCssOptions Compact -- | default fonts. defaultCssFontFamilies :: ByteString defaultCssFontFamilies = [i| svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; } ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; } |] -- | CSS glyphShape rendering options data ShapeRendering = UseGeometricPrecision | UseCssCrisp | NoShapeRendering deriving (Show, Eq, Generic) -- | CSS prefer-color-scheme options data PreferColorScheme = -- | includes css that switches approriate hud elements between light and dark. PreferHud | PreferDark | PreferLight | PreferNormal deriving (Show, Eq, Generic) -- | css options -- -- >>> defaultCssOptions -- CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, fontFamilies = "\nsvg { font-family: system-ui,-apple-system,\"Segoe UI\",Roboto,\"Helvetica Neue\",Arial,\"Noto Sans\",\"Liberation Sans\",sans-serif,\"Apple Color Emoji\",\"Segoe UI Emoji\",\"Segoe UI Symbol\",\"Noto Color Emoji\";\n}\n\nticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,\"Liberation Mono\",\"Courier New\",monospace;\n}\n\n", cssExtra = ""} data CssOptions = CssOptions {shapeRendering :: ShapeRendering, preferColorScheme :: PreferColorScheme, fontFamilies :: ByteString, cssExtra :: ByteString} deriving (Show, Eq, Generic) -- | No special shape rendering and default hud responds to user color scheme preferences. defaultCssOptions :: CssOptions defaultCssOptions = CssOptions NoShapeRendering PreferHud defaultCssFontFamilies mempty -- | Convert CssOptions to Markup markupCssOptions :: CssOptions -> Markup markupCssOptions css = elementc "style" [] $ cssPreferColorScheme (light, dark) (view #preferColorScheme css) <> markupShapeRendering (view #shapeRendering css) <> view #fontFamilies css <> view #cssExtra css -- | CSS shape rendering text snippet markupShapeRendering :: ShapeRendering -> ByteString markupShapeRendering UseGeometricPrecision = "svg { shape-rendering: geometricPrecision; }" markupShapeRendering UseCssCrisp = "svg { shape-rendering: crispEdges; }" markupShapeRendering NoShapeRendering = mempty -- | A product type consisting of a 'ChartTree', 'HudOptions' and 'MarkupOptions', which is what you need to create 'Markup'. data ChartOptions = ChartOptions { markupOptions :: MarkupOptions, hudOptions :: HudOptions, chartTree :: ChartTree } deriving (Generic, Eq, Show) -- | Processes the hud options and turns them into charts, rescales the existing charts, resets the hud options to mempty, and turns on 'ScalePArea' in chart styles. -- -- Note that this is a destructive operation, and, in particular, that -- -- > view #chartTree (forgetHud (mempty & set #chartTree c)) /= c forgetHud :: ChartOptions -> ChartOptions forgetHud co = co & set #hudOptions mempty & set #chartTree (addHud (view (#markupOptions % #chartAspect) co) (view #hudOptions co) (view #chartTree co)) & set (#chartTree % charts' % each % #chartStyle % #scaleP) ScalePArea -- | Convert ChartOptions to Markup -- -- >>> markupChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) & markdown_ Compact Xml -- "" markupChartOptions :: ChartOptions -> Markup markupChartOptions co = header (view (#markupOptions % #markupHeight) co) viewbox ( markupCssOptions (view (#markupOptions % #cssOptions) co) <> markupChartTree ctFinal ) where viewbox = view safeStyleBox' ctFinal ctFinal = projectChartTreeWith (view (#markupOptions % #chartAspect) co) (view #hudOptions co) (view #chartTree co) -- | Render ChartOptions to an SVG ByteString -- -- >>> encodeChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) -- "" encodeChartOptions :: ChartOptions -> ByteString encodeChartOptions co = markdown_ (view (#markupOptions % #renderStyle) co) Xml $ markupChartOptions co -- | Render ChartOptions to an SVG Text snippet -- -- >>> renderChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) -- "" renderChartOptions :: ChartOptions -> Text renderChartOptions = decodeUtf8 . encodeChartOptions instance Semigroup ChartOptions where (<>) (ChartOptions _ h c) (ChartOptions s' h' c') = ChartOptions s' (h <> h') (c <> c') instance Monoid ChartOptions where mempty = ChartOptions defaultMarkupOptions mempty mempty -- | Convert ChartOptions to an SVG ByteString and save to a file writeChartOptions :: FilePath -> ChartOptions -> IO () writeChartOptions fp co = Data.ByteString.writeFile fp (encodeChartOptions co)