{-# 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 :: Double -> ByteString
encodeNum = Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormatStyle -> Maybe Int -> Double -> Text
formatOrShow (Int -> FormatStyle
FixedStyle Int
4) forall a. Maybe a
Nothing

-- | SVG width and height, without any unit suffix, are defined as pixels, which are Integers
--
-- >>> encodePx 300.0
-- "300"
encodePx :: Double -> ByteString
encodePx :: Double -> ByteString
encodePx = String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (RealFrac a, Integral b) => a -> b
floor :: Double -> Int)

-- | Convert a ChartTree to markup
--
-- >>> lineExample & view #chartTree & markupChartTree & markdown_ Compact Xml
-- "<g class=\"line\"><g stroke-width=\"0.0150\" stroke=\"rgb(2%, 73%, 80%)\" stroke-opacity=\"1.0\" fill=\"none\"><polyline points=\"0,-1.0 1.0,-1.0 2.0,-5.0\"/></g><g stroke-width=\"0.0150\" stroke=\"rgb(2%, 29%, 48%)\" stroke-opacity=\"1.0\" fill=\"none\"><polyline points=\"0,0 2.8,-3.0\"/></g><g stroke-width=\"0.0150\" stroke=\"rgb(66%, 7%, 55%)\" stroke-opacity=\"1.0\" fill=\"none\"><polyline points=\"0.5,-4.0 0.5,0\"/></g></g>"
markupChartTree :: ChartTree -> Markup
markupChartTree :: ChartTree -> Markup
markupChartTree ChartTree
cs =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Markup
xs' (\Text
l -> ByteString -> [Attr] -> Markup -> Markup
element ByteString
"g" [ByteString -> ByteString -> Attr
Attr ByteString
"class" (Text -> ByteString
encodeUtf8 Text
l)] Markup
xs') Maybe Text
label
  where
    (ChartTree (Node (Maybe Text
label, [Chart]
cs') [Tree (Maybe Text, [Chart])]
xs)) = (Chart -> Bool) -> ChartTree -> ChartTree
filterChartTree (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChartData -> Bool
isEmptyChart forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chart -> ChartData
chartData) ChartTree
cs
    xs' :: Markup
xs' = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Chart -> Markup
markupChart [Chart]
cs' forall a. Semigroup a => a -> a -> a
<> (ChartTree -> Markup
markupChartTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (Maybe Text, [Chart]) -> ChartTree
ChartTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (Maybe Text, [Chart])]
xs)

markupText :: Style -> Text -> Point Double -> Markup
markupText :: Style -> Text -> Point Double -> Markup
markupText Style
s Text
t p :: Point Double
p@(Point Double
x Double
y) = Markup
frame' forall a. Semigroup a => a -> a -> a
<> ByteString -> [Attr] -> Markup -> Markup
element ByteString
"text" [Attr]
as (forall a. a -> a -> Bool -> a
bool (ByteString -> Markup
contentRaw ByteString
c) (ByteString -> Markup
content ByteString
c) (EscapeText
EscapeText forall a. Eq a => a -> a -> Bool
== forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "escapeText" a => a
#escapeText Style
s))
  where
    as :: [Attr]
as =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"x", Double -> ByteString
encodeNum Double
x),
              (ByteString
"y", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ -Double
y)
            ]
          forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> [a]
maybeToList ((\Double
x' -> (ByteString
"transform", Double -> Point Double -> ByteString
toRotateText Double
x' Point Double
p)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "rotation" a => a
#rotation Style
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' :: Markup
frame' = case forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "frame" a => a
#frame Style
s of
      Maybe Style
Nothing -> [Element] -> Markup
Markup forall a. Monoid a => a
mempty
      Just Style
f -> Chart -> Markup
markupChart (Style -> ChartData -> Chart
Chart (Style
f forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over forall a. IsLabel "borderSize" a => a
#borderSize (forall a. Num a => a -> a -> a
* forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "size" a => a
#size Style
s)) ([Rect Double] -> ChartData
RectData [Style -> Text -> Point Double -> Rect Double
styleBoxText (Style
s forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set forall a. IsLabel "frame" a => a
#frame forall a. Maybe a
Nothing) Text
t Point Double
p]))
    c :: ByteString
c = Text -> ByteString
encodeUtf8 Text
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 :: Double -> Point Double -> ByteString
toRotateText Double
r (Point Double
x Double
y) =
  ByteString
"rotate(" forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-(Double
r forall a. Num a => a -> a -> a
* Double
180 forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi)) forall a. Semigroup a => a -> a -> a
<> ByteString
", " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum Double
x forall a. Semigroup a => a -> a -> a
<> ByteString
", " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-Double
y) forall a. Semigroup a => a -> a -> a
<> ByteString
")"

toScaleText :: Double -> ByteString
toScaleText :: Double -> ByteString
toScaleText Double
x =
  ByteString
"scale(" forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum Double
x forall a. Semigroup a => a -> a -> a
<> ByteString
")"

-- | Convert a Rect to Markup
markupRect :: Rect Double -> Markup
markupRect :: Rect Double -> Markup
markupRect (Rect Double
x Double
z Double
y Double
w) =
  ByteString -> [Attr] -> Markup
emptyElem ByteString
"rect" [Attr]
as
  where
    as :: [Attr]
as =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"width", Double -> ByteString
encodeNum (Double
z forall a. Num a => a -> a -> a
- Double
x)),
              (ByteString
"height", Double -> ByteString
encodeNum (Double
w forall a. Num a => a -> a -> a
- Double
y)),
              (ByteString
"x", Double -> ByteString
encodeNum Double
x),
              (ByteString
"y", Double -> ByteString
encodeNum (-Double
w))
            ]

-- | Convert a Chart to Markup
--
-- >>> import MarkupParse
-- >>> import Optics.Core
-- >>> import Control.Category ((>>>))
-- >>> lineExample & toListOf (#chartTree % charts') & mconcat & fmap (markupChart >>> markdown_ Compact Xml)
-- ["<g stroke-width=\"0.0150\" stroke=\"rgb(2%, 73%, 80%)\" stroke-opacity=\"1.0\" fill=\"none\"><polyline points=\"0,-1.0 1.0,-1.0 2.0,-5.0\"/></g>","<g stroke-width=\"0.0150\" stroke=\"rgb(2%, 29%, 48%)\" stroke-opacity=\"1.0\" fill=\"none\"><polyline points=\"0,0 2.8,-3.0\"/></g>","<g stroke-width=\"0.0150\" stroke=\"rgb(66%, 7%, 55%)\" stroke-opacity=\"1.0\" fill=\"none\"><polyline points=\"0.5,-4.0 0.5,0\"/></g>"]
markupChart :: Chart -> Markup
markupChart :: Chart -> Markup
markupChart = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ByteString -> [Attr] -> Markup -> Markup
element ByteString
"g") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chart -> ([Attr], Markup)
f
  where
    f :: Chart -> ([Attr], Markup)
f (Chart Style
s (RectData [Rect Double]
xs)) = (Style -> [Attr]
attsRect Style
s, forall a. Monoid a => [a] -> a
mconcat (Rect Double -> Markup
markupRect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rect Double]
xs))
    f (Chart Style
s (TextData [(Text, Point Double)]
xs)) = (Style -> [Attr]
attsText Style
s, forall a. Monoid a => [a] -> a
mconcat (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Style -> Text -> Point Double -> Markup
markupText Style
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Point Double)]
xs))
    f (Chart Style
s (GlyphData [Point Double]
xs)) = (Style -> [Attr]
attsGlyph Style
s, forall a. Monoid a => [a] -> a
mconcat (Style -> Point Double -> Markup
markupGlyph Style
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
xs))
    f (Chart Style
s (PathData [PathData Double]
xs)) = (Style -> [Attr]
attsPath Style
s, [PathData Double] -> Markup
markupPath [PathData Double]
xs)
    f (Chart Style
s (LineData [[Point Double]]
xs)) = (Style -> [Attr]
attsLine Style
s, [[Point Double]] -> Markup
markupLine [[Point Double]]
xs)
    f (Chart Style
_ (BlankData [Rect Double]
_)) = ([], forall a. Monoid a => a
mempty)

markupLine :: [[Point Double]] -> Markup
markupLine :: [[Point Double]] -> Markup
markupLine [[Point Double]]
lss =
  forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ ByteString -> [Attr] -> Markup
emptyElem ByteString
"polyline" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Attr
Attr ByteString
"points" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point Double] -> ByteString
toPointsText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Point Double]]
lss

toPointsText :: [Point Double] -> ByteString
toPointsText :: [Point Double] -> ByteString
toPointsText [Point Double]
xs = ByteString -> [ByteString] -> ByteString
intercalate ByteString
" " forall a b. (a -> b) -> a -> b
$ (\(Point Double
x Double
y) -> Double -> ByteString
encodeNum Double
x forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-Double
y)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
xs

-- | Path markup
markupPath :: [PathData Double] -> Markup
markupPath :: [PathData Double] -> Markup
markupPath [PathData Double]
ps =
  ByteString -> [Attr] -> Markup
emptyElem ByteString
"path" [ByteString -> ByteString -> Attr
Attr ByteString
"d" ([PathData Double] -> ByteString
pathDataToSvg [PathData Double]
ps)]

-- | GlyphStyle to markup Tree
-- Note rotation on the outside not the inside.
markupGlyph :: Style -> Point Double -> Markup
markupGlyph :: Style -> Point Double -> Markup
markupGlyph Style
s Point Double
p =
  case forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "rotation" a => a
#rotation Style
s of
    Maybe Double
Nothing -> Markup
gl
    Just Double
r -> ByteString -> [Attr] -> Markup -> Markup
element ByteString
"g" [ByteString -> ByteString -> Attr
Attr ByteString
"transform" (Double -> Point Double -> ByteString
toRotateText Double
r Point Double
p)] Markup
gl
  where
    gl :: Markup
gl = GlyphShape -> Double -> Point Double -> Markup
markupShape_ (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "glyphShape" a => a
#glyphShape Style
s) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "size" a => a
#size Style
s) Point Double
p

-- | Convert a dash representation from a list to text
fromDashArray :: [Double] -> ByteString
fromDashArray :: [Double] -> ByteString
fromDashArray [Double]
xs = ByteString -> [ByteString] -> ByteString
intercalate ByteString
" " forall a b. (a -> b) -> a -> b
$ Double -> ByteString
encodeNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
xs

fromDashOffset :: Double -> ByteString
fromDashOffset :: Double -> ByteString
fromDashOffset Double
x = Double -> ByteString
encodeNum Double
x

attsLine :: Style -> [Attr]
attsLine :: Style -> [Attr]
attsLine Style
o =
  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"stroke-width", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "size" a => a
#size Style
o),
          (ByteString
"stroke", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o),
          (ByteString
"stroke-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o),
          (ByteString
"fill", ByteString
"none")
        ]
      forall a. Semigroup a => a -> a -> a
<> forall a. [Maybe a] -> [a]
catMaybes
        [(\LineCap
x -> (ByteString
"stroke-linecap", forall s. IsString s => LineCap -> s
fromLineCap LineCap
x)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "lineCap" a => a
#lineCap Style
o]
      forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\LineJoin
x -> [(ByteString
"stroke-linejoin", forall s. IsString s => LineJoin -> s
fromLineJoin LineJoin
x)]) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "lineJoin" a => a
#lineJoin Style
o)
      forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\[Double]
x -> [(ByteString
"stroke-dasharray", [Double] -> ByteString
fromDashArray [Double]
x)]) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "dasharray" a => a
#dasharray Style
o)
      forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Double
x -> [(ByteString
"stroke-dashoffset", Double -> ByteString
fromDashOffset Double
x)]) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "dashoffset" a => a
#dashoffset Style
o)

attsRect :: Style -> [Attr]
attsRect :: Style -> [Attr]
attsRect Style
o =
  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"stroke-width", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderSize" a => a
#borderSize Style
o),
          (ByteString
"stroke", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderColor" a => a
#borderColor Style
o),
          (ByteString
"stroke-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderColor" a => a
#borderColor Style
o),
          (ByteString
"fill", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o),
          (ByteString
"fill-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o)
        ]

-- | TextStyle to [Attr]
attsText :: Style -> [Attr]
attsText :: Style -> [Attr]
attsText Style
o =
  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"stroke-width", ByteString
"0.0"),
          (ByteString
"stroke", ByteString
"none"),
          (ByteString
"fill", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o),
          (ByteString
"fill-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o),
          (ByteString
"font-size", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "size" a => a
#size Style
o),
          (ByteString
"text-anchor", Anchor -> ByteString
toTextAnchor forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "anchor" a => a
#anchor Style
o)
        ]
  where
    toTextAnchor :: Anchor -> ByteString
    toTextAnchor :: Anchor -> ByteString
toTextAnchor Anchor
AnchorMiddle = ByteString
"middle"
    toTextAnchor Anchor
AnchorStart = ByteString
"start"
    toTextAnchor Anchor
AnchorEnd = ByteString
"end"

-- | GlyphStyle to [Attr]
attsGlyph :: Style -> [Attr]
attsGlyph :: Style -> [Attr]
attsGlyph Style
o =
  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"stroke-width", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderSize" a => a
#borderSize Style
o),
          (ByteString
"stroke", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderColor" a => a
#borderColor Style
o),
          (ByteString
"stroke-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderColor" a => a
#borderColor Style
o),
          (ByteString
"fill", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o),
          (ByteString
"fill-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o)
        ]
      forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((forall a. a -> [a] -> [a]
: []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) ByteString
"transform" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point Double -> ByteString
toTranslateText) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "translate" a => a
#translate Style
o)

-- | PathStyle to [Attr]
attsPath :: Style -> [Attr]
attsPath :: Style -> [Attr]
attsPath Style
o =
  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"stroke-width", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderSize" a => a
#borderSize Style
o),
          (ByteString
"stroke", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderColor" a => a
#borderColor Style
o),
          (ByteString
"stroke-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "borderColor" a => a
#borderColor Style
o),
          (ByteString
"fill", Colour -> ByteString
showRGB forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o),
          (ByteString
"fill-opacity", Colour -> ByteString
showOpacity forall a b. (a -> b) -> a -> b
$ forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "color" a => a
#color Style
o)
        ]

-- | includes a flip of the y dimension.
toTranslateText :: Point Double -> ByteString
toTranslateText :: Point Double -> ByteString
toTranslateText (Point Double
x Double
y) =
  ByteString
"translate(" forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum Double
x forall a. Semigroup a => a -> a -> a
<> ByteString
", " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-Double
y) forall a. Semigroup a => a -> a -> a
<> ByteString
")"

-- | GlyphShape to markup Tree
markupShape_ :: GlyphShape -> Double -> Point Double -> Markup
markupShape_ :: GlyphShape -> Double -> Point Double -> Markup
markupShape_ GlyphShape
CircleGlyph Double
s (Point Double
x Double
y) = ByteString -> [Attr] -> Markup
emptyElem ByteString
"circle" [Attr]
as
  where
    as :: [Attr]
as =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"cx", Double -> ByteString
encodeNum Double
x),
              (ByteString
"cy", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ -Double
y),
              (ByteString
"r", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ Double
0.5 forall a. Num a => a -> a -> a
* Double
s)
            ]
markupShape_ GlyphShape
SquareGlyph Double
s Point Double
p =
  Rect Double -> Markup
markupRect (forall s. (Additive (Element s), Space s) => Element s -> s -> s
move Point Double
p ((Double
s *) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Multiplicative a => a
one :: Rect Double))
markupShape_ (RectSharpGlyph Double
x') Double
s Point Double
p =
  Rect Double -> Markup
markupRect (forall s. (Additive (Element s), Space s) => Element s -> s -> s
move Point Double
p (forall s.
(Multiplicative (Element s), Space s) =>
Element s -> s -> s
scale (forall a. a -> a -> Point a
Point Double
s (Double
x' forall a. Num a => a -> a -> a
* Double
s)) forall a. Multiplicative a => a
one :: Rect Double))
markupShape_ (RectRoundedGlyph Double
x' Double
rx Double
ry) Double
s Point Double
p = ByteString -> [Attr] -> Markup
emptyElem ByteString
"rect" [Attr]
as
  where
    as :: [Attr]
as =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"width", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ Double
z forall a. Num a => a -> a -> a
- Double
x),
              (ByteString
"height", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ Double
w forall a. Num a => a -> a -> a
- Double
y),
              (ByteString
"x", Double -> ByteString
encodeNum Double
x),
              (ByteString
"y", Double -> ByteString
encodeNum forall a b. (a -> b) -> a -> b
$ -Double
w),
              (ByteString
"rx", Double -> ByteString
encodeNum Double
rx),
              (ByteString
"ry", Double -> ByteString
encodeNum Double
ry)
            ]
    (Rect Double
x Double
z Double
y Double
w) = forall s. (Additive (Element s), Space s) => Element s -> s -> s
move Point Double
p (forall s.
(Multiplicative (Element s), Space s) =>
Element s -> s -> s
scale (forall a. a -> a -> Point a
Point Double
s (Double
x' forall a. Num a => a -> a -> a
* Double
s)) forall a. Multiplicative a => a
one)
markupShape_ (TriangleGlyph (Point Double
xa Double
ya) (Point Double
xb Double
yb) (Point Double
xc Double
yc)) Double
s Point Double
p =
  ByteString -> [Attr] -> Markup
emptyElem ByteString
"polygon" [Attr]
as
  where
    as :: [Attr]
as =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"transform", Point Double -> ByteString
toTranslateText Point Double
p),
              (ByteString
"points", Double -> ByteString
encodeNum (Double
s forall a. Num a => a -> a -> a
* Double
xa) forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-(Double
s forall a. Num a => a -> a -> a
* Double
ya)) forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (Double
s forall a. Num a => a -> a -> a
* Double
xb) forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-(Double
s forall a. Num a => a -> a -> a
* Double
yb)) forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (Double
s forall a. Num a => a -> a -> a
* Double
xc) forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-(Double
s forall a. Num a => a -> a -> a
* Double
yc)))
            ]
markupShape_ (EllipseGlyph Double
x') Double
s (Point Double
x Double
y) =
  ByteString -> [Attr] -> Markup
emptyElem ByteString
"ellipse" [Attr]
as
  where
    as :: [Attr]
as =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (ByteString
"cx", (String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Double
x),
              (ByteString
"cy", (String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$ -Double
y),
              (ByteString
"rx", (String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$ Double
0.5 forall a. Num a => a -> a -> a
* Double
s),
              (ByteString
"ry", (String -> ByteString
strToUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$ Double
0.5 forall a. Num a => a -> a -> a
* Double
s forall a. Num a => a -> a -> a
* Double
x')
            ]
markupShape_ GlyphShape
VLineGlyph Double
s (Point Double
x Double
y) =
  ByteString -> [Attr] -> Markup
emptyElem ByteString
"polyline" [ByteString -> ByteString -> Attr
Attr ByteString
"points" forall a b. (a -> b) -> a -> b
$ Double -> ByteString
encodeNum Double
x forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-(Double
y forall a. Num a => a -> a -> a
- Double
s forall a. Fractional a => a -> a -> a
/ Double
2)) forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum Double
x forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-(Double
y forall a. Num a => a -> a -> a
+ Double
s forall a. Fractional a => a -> a -> a
/ Double
2))]
markupShape_ GlyphShape
HLineGlyph Double
s (Point Double
x Double
y) =
  ByteString -> [Attr] -> Markup
emptyElem ByteString
"polyline" [ByteString -> ByteString -> Attr
Attr ByteString
"points" forall a b. (a -> b) -> a -> b
$ Double -> ByteString
encodeNum (Double
x forall a. Num a => a -> a -> a
- Double
s forall a. Fractional a => a -> a -> a
/ Double
2) forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-Double
y) forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (Double
x forall a. Num a => a -> a -> a
+ Double
s forall a. Fractional a => a -> a -> a
/ Double
2) forall a. Semigroup a => a -> a -> a
<> ByteString
"," forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-Double
y)]
markupShape_ (PathGlyph ByteString
path) Double
s Point Double
p =
  ByteString -> [Attr] -> Markup
emptyElem ByteString
"path" (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ByteString
"d", ByteString
path), (ByteString
"transform", Point Double -> ByteString
toTranslateText Point Double
p forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
toScaleText Double
s)])

-- | Create the classic SVG element
--
-- >>> header (Just 300) (Rect (-0.75) 0.75 (-0.5) 0.5) (element_ "foo" []) & markdown_ Compact Xml
-- "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" width=\"450\" height=\"300\" viewBox=\"-0.75 -0.5 1.5 1.0\"><foo></foo></svg>"
header :: Maybe Double -> Rect Double -> Markup -> Markup
header :: Maybe Double -> Rect Double -> Markup -> Markup
header Maybe Double
markupheight Rect Double
viewbox Markup
content' =
  ByteString -> [Attr] -> Markup -> Markup
element
    ByteString
"svg"
    ( forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Attr
Attr
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( [ (ByteString
"xmlns", ByteString
"http://www.w3.org/2000/svg"),
                (ByteString
"xmlns:xlink", ByteString
"http://www.w3.org/1999/xlink")
              ]
                forall a. Semigroup a => a -> a -> a
<> [(ByteString, ByteString)]
widthAndHeight
                forall a. Semigroup a => a -> a -> a
<> [ (ByteString
"viewBox", Double -> ByteString
encodeNum Double
x forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (-Double
w) forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (Double
z forall a. Num a => a -> a -> a
- Double
x) forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
encodeNum (Double
w forall a. Num a => a -> a -> a
- Double
y))
                   ]
            )
    )
    Markup
content'
  where
    (Rect Double
x Double
z Double
y Double
w) = Rect Double
viewbox
    Point Double
w' Double
h = forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Rect Double
viewbox
    widthAndHeight :: [(ByteString, ByteString)]
widthAndHeight = case Maybe Double
markupheight of
      Maybe Double
Nothing -> []
      Just Double
h' ->
        [ (ByteString
"width", Double -> ByteString
encodePx Double
w''),
          (ByteString
"height", Double -> ByteString
encodePx Double
h')
        ]
        where
          w'' :: Double
w'' = Double
h' forall a. Fractional a => a -> a -> a
/ Double
h forall a. Num a => a -> a -> a
* Double
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 :: (Colour, Colour) -> PreferColorScheme -> ByteString
cssPreferColorScheme (Colour
cl, Colour
cd) PreferColorScheme
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 (Colour
cl, Colour
_) PreferColorScheme
PreferLight =
  [i|svg {
      color-scheme: light dark;
    }
    @media (prefers-color-scheme:dark) {
      markup {
        background-color: #{showRGB cl};
      }
    }|]
cssPreferColorScheme (Colour
_, Colour
cd) PreferColorScheme
PreferDark =
  [i|svg {
      color-scheme: light dark;
    }
    @media (prefers-color-scheme:light) {
      markup {
        background-color: #{showRGB cd};
      }
    }|]
cssPreferColorScheme (Colour, Colour)
_ PreferColorScheme
PreferNormal = forall a. Monoid a => a
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 :: (Colour, Colour) -> ByteString -> ByteString -> ByteString
fillSwitch (Colour
colorNormal, Colour
colorPrefer) ByteString
prefer ByteString
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
  { MarkupOptions -> Maybe Double
markupHeight :: Maybe Double,
    MarkupOptions -> ChartAspect
chartAspect :: ChartAspect,
    MarkupOptions -> CssOptions
cssOptions :: CssOptions,
    MarkupOptions -> RenderStyle
renderStyle :: RenderStyle
  }
  deriving (MarkupOptions -> MarkupOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MarkupOptions -> MarkupOptions -> Bool
$c/= :: MarkupOptions -> MarkupOptions -> Bool
== :: MarkupOptions -> MarkupOptions -> Bool
$c== :: MarkupOptions -> MarkupOptions -> Bool
Eq, Int -> MarkupOptions -> ShowS
[MarkupOptions] -> ShowS
MarkupOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MarkupOptions] -> ShowS
$cshowList :: [MarkupOptions] -> ShowS
show :: MarkupOptions -> String
$cshow :: MarkupOptions -> String
showsPrec :: Int -> MarkupOptions -> ShowS
$cshowsPrec :: Int -> MarkupOptions -> ShowS
Show, forall x. Rep MarkupOptions x -> MarkupOptions
forall x. MarkupOptions -> Rep MarkupOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MarkupOptions x -> MarkupOptions
$cfrom :: forall x. MarkupOptions -> Rep MarkupOptions x
Generic)

-- | The official markup options
defaultMarkupOptions :: MarkupOptions
defaultMarkupOptions :: MarkupOptions
defaultMarkupOptions = Maybe Double
-> ChartAspect -> CssOptions -> RenderStyle -> MarkupOptions
MarkupOptions (forall a. a -> Maybe a
Just Double
300) (Double -> ChartAspect
FixedAspect Double
1.5) CssOptions
defaultCssOptions RenderStyle
Compact

-- | default fonts.
defaultCssFontFamilies :: ByteString
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 (Int -> ShapeRendering -> ShowS
[ShapeRendering] -> ShowS
ShapeRendering -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShapeRendering] -> ShowS
$cshowList :: [ShapeRendering] -> ShowS
show :: ShapeRendering -> String
$cshow :: ShapeRendering -> String
showsPrec :: Int -> ShapeRendering -> ShowS
$cshowsPrec :: Int -> ShapeRendering -> ShowS
Show, ShapeRendering -> ShapeRendering -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShapeRendering -> ShapeRendering -> Bool
$c/= :: ShapeRendering -> ShapeRendering -> Bool
== :: ShapeRendering -> ShapeRendering -> Bool
$c== :: ShapeRendering -> ShapeRendering -> Bool
Eq, forall x. Rep ShapeRendering x -> ShapeRendering
forall x. ShapeRendering -> Rep ShapeRendering x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShapeRendering x -> ShapeRendering
$cfrom :: forall x. ShapeRendering -> Rep ShapeRendering x
Generic)

-- | CSS prefer-color-scheme options
data PreferColorScheme
  = -- | includes css that switches approriate hud elements between light and dark.
    PreferHud
  | PreferDark
  | PreferLight
  | PreferNormal
  deriving (Int -> PreferColorScheme -> ShowS
[PreferColorScheme] -> ShowS
PreferColorScheme -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PreferColorScheme] -> ShowS
$cshowList :: [PreferColorScheme] -> ShowS
show :: PreferColorScheme -> String
$cshow :: PreferColorScheme -> String
showsPrec :: Int -> PreferColorScheme -> ShowS
$cshowsPrec :: Int -> PreferColorScheme -> ShowS
Show, PreferColorScheme -> PreferColorScheme -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreferColorScheme -> PreferColorScheme -> Bool
$c/= :: PreferColorScheme -> PreferColorScheme -> Bool
== :: PreferColorScheme -> PreferColorScheme -> Bool
$c== :: PreferColorScheme -> PreferColorScheme -> Bool
Eq, forall x. Rep PreferColorScheme x -> PreferColorScheme
forall x. PreferColorScheme -> Rep PreferColorScheme x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PreferColorScheme x -> PreferColorScheme
$cfrom :: forall x. PreferColorScheme -> Rep PreferColorScheme x
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 {CssOptions -> ShapeRendering
shapeRendering :: ShapeRendering, CssOptions -> PreferColorScheme
preferColorScheme :: PreferColorScheme, CssOptions -> ByteString
fontFamilies :: ByteString, CssOptions -> ByteString
cssExtra :: ByteString} deriving (Int -> CssOptions -> ShowS
[CssOptions] -> ShowS
CssOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CssOptions] -> ShowS
$cshowList :: [CssOptions] -> ShowS
show :: CssOptions -> String
$cshow :: CssOptions -> String
showsPrec :: Int -> CssOptions -> ShowS
$cshowsPrec :: Int -> CssOptions -> ShowS
Show, CssOptions -> CssOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CssOptions -> CssOptions -> Bool
$c/= :: CssOptions -> CssOptions -> Bool
== :: CssOptions -> CssOptions -> Bool
$c== :: CssOptions -> CssOptions -> Bool
Eq, forall x. Rep CssOptions x -> CssOptions
forall x. CssOptions -> Rep CssOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CssOptions x -> CssOptions
$cfrom :: forall x. CssOptions -> Rep CssOptions x
Generic)

-- | No special shape rendering and default hud responds to user color scheme preferences.
defaultCssOptions :: CssOptions
defaultCssOptions :: CssOptions
defaultCssOptions = ShapeRendering
-> PreferColorScheme -> ByteString -> ByteString -> CssOptions
CssOptions ShapeRendering
NoShapeRendering PreferColorScheme
PreferHud ByteString
defaultCssFontFamilies forall a. Monoid a => a
mempty

-- | Convert CssOptions to Markup
markupCssOptions :: CssOptions -> Markup
markupCssOptions :: CssOptions -> Markup
markupCssOptions CssOptions
css =
  ByteString -> [Attr] -> ByteString -> Markup
elementc ByteString
"style" [] forall a b. (a -> b) -> a -> b
$
    (Colour, Colour) -> PreferColorScheme -> ByteString
cssPreferColorScheme (Colour
light, Colour
dark) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "preferColorScheme" a => a
#preferColorScheme CssOptions
css)
      forall a. Semigroup a => a -> a -> a
<> ShapeRendering -> ByteString
markupShapeRendering (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "shapeRendering" a => a
#shapeRendering CssOptions
css)
      forall a. Semigroup a => a -> a -> a
<> forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "fontFamilies" a => a
#fontFamilies CssOptions
css
      forall a. Semigroup a => a -> a -> a
<> forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "cssExtra" a => a
#cssExtra CssOptions
css

-- | CSS shape rendering text snippet
markupShapeRendering :: ShapeRendering -> ByteString
markupShapeRendering :: ShapeRendering -> ByteString
markupShapeRendering ShapeRendering
UseGeometricPrecision = ByteString
"svg { shape-rendering: geometricPrecision; }"
markupShapeRendering ShapeRendering
UseCssCrisp = ByteString
"svg { shape-rendering: crispEdges; }"
markupShapeRendering ShapeRendering
NoShapeRendering = forall a. Monoid a => a
mempty

-- | A product type consisting of a 'ChartTree', 'HudOptions' and 'MarkupOptions', which is what you need to create 'Markup'.
data ChartOptions = ChartOptions
  { ChartOptions -> MarkupOptions
markupOptions :: MarkupOptions,
    ChartOptions -> HudOptions
hudOptions :: HudOptions,
    ChartOptions -> ChartTree
chartTree :: ChartTree
  }
  deriving (forall x. Rep ChartOptions x -> ChartOptions
forall x. ChartOptions -> Rep ChartOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChartOptions x -> ChartOptions
$cfrom :: forall x. ChartOptions -> Rep ChartOptions x
Generic, ChartOptions -> ChartOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChartOptions -> ChartOptions -> Bool
$c/= :: ChartOptions -> ChartOptions -> Bool
== :: ChartOptions -> ChartOptions -> Bool
$c== :: ChartOptions -> ChartOptions -> Bool
Eq, Int -> ChartOptions -> ShowS
[ChartOptions] -> ShowS
ChartOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChartOptions] -> ShowS
$cshowList :: [ChartOptions] -> ShowS
show :: ChartOptions -> String
$cshow :: ChartOptions -> String
showsPrec :: Int -> ChartOptions -> ShowS
$cshowsPrec :: Int -> ChartOptions -> ShowS
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 :: ChartOptions -> ChartOptions
forgetHud ChartOptions
co =
  ChartOptions
co
    forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set forall a. IsLabel "hudOptions" a => a
#hudOptions forall a. Monoid a => a
mempty
    forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set forall a. IsLabel "chartTree" a => a
#chartTree (ChartAspect -> HudOptions -> ChartTree -> ChartTree
addHud (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall a. IsLabel "markupOptions" a => a
#markupOptions forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "chartAspect" a => a
#chartAspect) ChartOptions
co) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "hudOptions" a => a
#hudOptions ChartOptions
co) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "chartTree" a => a
#chartTree ChartOptions
co))
    forall a b. a -> (a -> b) -> b
& forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (forall a. IsLabel "chartTree" a => a
#chartTree forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Traversal' ChartTree [Chart]
charts' forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall i s t a b. Each i s t a b => IxTraversal i s t a b
each forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "chartStyle" a => a
#chartStyle forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "scaleP" a => a
#scaleP) ScaleP
ScalePArea

-- | Convert ChartOptions to Markup
--
-- >>> markupChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) & markdown_ Compact Xml
-- "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" width=\"300\" height=\"300\" viewBox=\"-0.5 -0.5 1.0 1.0\"><style>\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</style><g class=\"chart\"></g><g class=\"hud\"></g></svg>"
markupChartOptions :: ChartOptions -> Markup
markupChartOptions :: ChartOptions -> Markup
markupChartOptions ChartOptions
co =
  Maybe Double -> Rect Double -> Markup -> Markup
header
    (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall a. IsLabel "markupOptions" a => a
#markupOptions forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "markupHeight" a => a
#markupHeight) ChartOptions
co)
    Rect Double
viewbox
    ( CssOptions -> Markup
markupCssOptions (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall a. IsLabel "markupOptions" a => a
#markupOptions forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "cssOptions" a => a
#cssOptions) ChartOptions
co)
        forall a. Semigroup a => a -> a -> a
<> ChartTree -> Markup
markupChartTree ChartTree
ctFinal
    )
  where
    viewbox :: Rect Double
viewbox = forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Getter ChartTree (Rect Double)
safeStyleBox' ChartTree
ctFinal
    ctFinal :: ChartTree
ctFinal =
      ChartAspect -> HudOptions -> ChartTree -> ChartTree
projectChartTreeWith
        (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall a. IsLabel "markupOptions" a => a
#markupOptions forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "chartAspect" a => a
#chartAspect) ChartOptions
co)
        (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "hudOptions" a => a
#hudOptions ChartOptions
co)
        (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "chartTree" a => a
#chartTree ChartOptions
co)

-- | Render ChartOptions to an SVG ByteString
--
-- >>> encodeChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty)
-- "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" width=\"300\" height=\"300\" viewBox=\"-0.5 -0.5 1.0 1.0\"><style>\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</style><g class=\"chart\"></g><g class=\"hud\"></g></svg>"
encodeChartOptions :: ChartOptions -> ByteString
encodeChartOptions :: ChartOptions -> ByteString
encodeChartOptions ChartOptions
co = RenderStyle -> Standard -> Markup -> ByteString
markdown_ (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (forall a. IsLabel "markupOptions" a => a
#markupOptions forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a. IsLabel "renderStyle" a => a
#renderStyle) ChartOptions
co) Standard
Xml forall a b. (a -> b) -> a -> b
$ ChartOptions -> Markup
markupChartOptions ChartOptions
co

-- | Render ChartOptions to an SVG Text snippet
--
-- >>> renderChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty)
-- "<svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\" width=\"300\" height=\"300\" viewBox=\"-0.5 -0.5 1.0 1.0\"><style>\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</style><g class=\"chart\"></g><g class=\"hud\"></g></svg>"
renderChartOptions :: ChartOptions -> Text
renderChartOptions :: ChartOptions -> Text
renderChartOptions = ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChartOptions -> ByteString
encodeChartOptions

instance Semigroup ChartOptions where
  <> :: ChartOptions -> ChartOptions -> ChartOptions
(<>) (ChartOptions MarkupOptions
_ HudOptions
h ChartTree
c) (ChartOptions MarkupOptions
s' HudOptions
h' ChartTree
c') =
    MarkupOptions -> HudOptions -> ChartTree -> ChartOptions
ChartOptions MarkupOptions
s' (HudOptions
h forall a. Semigroup a => a -> a -> a
<> HudOptions
h') (ChartTree
c forall a. Semigroup a => a -> a -> a
<> ChartTree
c')

instance Monoid ChartOptions where
  mempty :: ChartOptions
mempty = MarkupOptions -> HudOptions -> ChartTree -> ChartOptions
ChartOptions MarkupOptions
defaultMarkupOptions forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | Convert ChartOptions to an SVG ByteString and save to a file
writeChartOptions :: FilePath -> ChartOptions -> IO ()
writeChartOptions :: String -> ChartOptions -> IO ()
writeChartOptions String
fp ChartOptions
co = String -> ByteString -> IO ()
Data.ByteString.writeFile String
fp (ChartOptions -> ByteString
encodeChartOptions ChartOptions
co)