{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wall #-}

-- | Conversion from a chart to SVG.
--
module Chart.Svg
  ( -- * ChartSvg
    ChartSvg (..),
    toChartTree,
    writeChartSvg,
    chartSvg,
    initialCanvas,

    -- * SVG Options
    SvgOptions (..),
    defaultSvgOptions,

    -- * SVG Style primitives
    CssOptions (..),
    defaultCssOptions,
    CssShapeRendering (..),
    CssPreferColorScheme (..),
    cssShapeRendering,
    cssPreferColorScheme,
  )
where

import Chart.Data
import Chart.Hud
import Chart.Primitive
import Chart.Style
import Data.Colour
import Data.Maybe
import Data.Path
import Data.Path.Parser
import Data.Text (Text, pack, unpack)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy
import Data.Tree
import GHC.Generics
import Lucid
import Lucid.Base
import NeatInterpolation
import Optics.Core
import Prelude

-- $setup
--
-- >>> :set -XOverloadedLabels
-- >>> :set -XOverloadedStrings
-- >>> import Chart
-- >>> import Optics.Core

-- helpers
--
draw :: Chart -> Html ()
draw :: Chart -> Html ()
draw (RectChart RectStyle
_ [Rect Double]
a) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Rect Double -> Html ()
svgRect_ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rect Double]
a
draw (TextChart TextStyle
s [(Text, Point Double)]
a) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (TextStyle -> Text -> Point Double -> Html ()
svgText_ TextStyle
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Point Double)]
a
draw (LineChart LineStyle
_ [[Point Double]]
as) = [[Point Double]] -> Html ()
svgLine_ [[Point Double]]
as
draw (GlyphChart GlyphStyle
s [Point Double]
a) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ GlyphStyle -> Point Double -> Html ()
svgGlyph_ GlyphStyle
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point Double]
a
draw (PathChart PathStyle
_ [PathData Double]
a) = [PathData Double] -> Html ()
svgPath_ [PathData Double]
a
draw (BlankChart [Rect Double]
_) = forall a. Monoid a => a
mempty

atts :: Chart -> [Attribute]
atts :: Chart -> [Attribute]
atts (RectChart RectStyle
s [Rect Double]
_) = RectStyle -> [Attribute]
attsRect RectStyle
s
atts (TextChart TextStyle
s [(Text, Point Double)]
_) = TextStyle -> [Attribute]
attsText TextStyle
s
atts (LineChart LineStyle
s [[Point Double]]
_) = LineStyle -> [Attribute]
attsLine LineStyle
s
atts (GlyphChart GlyphStyle
s [Point Double]
_) = GlyphStyle -> [Attribute]
attsGlyph GlyphStyle
s
atts (PathChart PathStyle
s [PathData Double]
_) = PathStyle -> [Attribute]
attsPath PathStyle
s
atts (BlankChart [Rect Double]
_) = forall a. Monoid a => a
mempty

svgChartTree :: ChartTree -> Lucid.Html ()
svgChartTree :: ChartTree -> Html ()
svgChartTree ChartTree
cs
  | forall a. Maybe a -> Bool
isNothing Maybe Text
label Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Chart]
cs' = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ ChartTree -> Html ()
svgChartTree 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
  | Bool
otherwise = forall arg result. Term arg result => Text -> arg -> result
term Text
"g" (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Text
x -> [forall arg result. Term arg result => Text -> arg -> result
term Text
"class" Text
x]) Maybe Text
label) Html ()
content'
  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
. Chart -> Bool
isEmptyChart) ChartTree
cs
    content' :: Html ()
content' = (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Chart -> Html ()
svg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Chart]
cs') forall a. Semigroup a => a -> a -> a
<> (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ ChartTree -> Html ()
svgChartTree 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)

-- ** ChartSvg

-- | Specification of a chart ready to be rendered to SVG includes:
--
-- - svg options
--
-- - hud options
--
-- - any extra hud elements beyond the usual options
--
-- - an underlying chart tree.
--
-- See Data.Examples for usage.
data ChartSvg = ChartSvg
  { ChartSvg -> SvgOptions
svgOptions :: SvgOptions,
    ChartSvg -> HudOptions
hudOptions :: HudOptions,
    ChartSvg -> [Hud]
extraHuds :: [Hud],
    ChartSvg -> ChartTree
charts :: ChartTree
  }
  deriving (forall x. Rep ChartSvg x -> ChartSvg
forall x. ChartSvg -> Rep ChartSvg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChartSvg x -> ChartSvg
$cfrom :: forall x. ChartSvg -> Rep ChartSvg x
Generic)

instance Semigroup ChartSvg where
  <> :: ChartSvg -> ChartSvg -> ChartSvg
(<>) (ChartSvg SvgOptions
_ HudOptions
o [Hud]
h ChartTree
c) (ChartSvg SvgOptions
s' HudOptions
o' [Hud]
h' ChartTree
c') =
    SvgOptions -> HudOptions -> [Hud] -> ChartTree -> ChartSvg
ChartSvg SvgOptions
s' (HudOptions
o forall a. Semigroup a => a -> a -> a
<> HudOptions
o') ([Hud]
h forall a. Semigroup a => a -> a -> a
<> [Hud]
h') (ChartTree
c forall a. Semigroup a => a -> a -> a
<> ChartTree
c')

instance Monoid ChartSvg where
  mempty :: ChartSvg
mempty = SvgOptions -> HudOptions -> [Hud] -> ChartTree -> ChartSvg
ChartSvg SvgOptions
defaultSvgOptions forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- * rendering

-- | @svg@ element + svg 2 attributes
svg2Tag :: Term [Attribute] (s -> t) => s -> t
svg2Tag :: forall s t. Term [Attribute] (s -> t) => s -> t
svg2Tag s
m =
  forall arg result. Term arg result => arg -> result
svg_
    [ Text -> Text -> Attribute
makeAttribute Text
"xmlns" Text
"http://www.w3.org/2000/svg",
      Text -> Text -> Attribute
makeAttribute Text
"xmlns:xlink" Text
"http://www.w3.org/1999/xlink"
    ]
    s
m

renderToText :: Html () -> Text
renderToText :: Html () -> Text
renderToText = Text -> Text
Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Html a -> Text
renderText

renderToSvg :: SvgOptions -> ChartTree -> Html ()
renderToSvg :: SvgOptions -> ChartTree -> Html ()
renderToSvg SvgOptions
so ChartTree
cs =
  forall a. With a => a -> [Attribute] -> a
with
    (forall s t. Term [Attribute] (s -> t) => s -> t
svg2Tag (CssOptions -> Html ()
cssText (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "cssOptions" a => a
#cssOptions SvgOptions
so) forall a. Semigroup a => a -> a -> a
<> ChartTree -> Html ()
svgChartTree ChartTree
cs))
    [ Text -> Attribute
width_ (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
w''),
      Text -> Attribute
height_ (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
h''),
      Text -> Text -> Attribute
makeAttribute Text
"viewBox" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
x forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-Double
w) forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Double
z forall a. Num a => a -> a -> a
- Double
x) forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Double
w forall a. Num a => a -> a -> a
- Double
y))
    ]
  where
    r :: Rect Double
r@(Rect Double
x Double
z Double
y Double
w) = Maybe (Rect Double) -> Rect Double
singletonGuard (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Lens' ChartTree (Maybe (Rect Double))
styleBox' ChartTree
cs)
    Point Double
w' Double
h' = forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Rect Double
r
    Point Double
w'' Double
h'' = forall a. a -> a -> Point a
Point ((SvgOptions
so forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "svgHeight" a => a
#svgHeight) forall a. Fractional a => a -> a -> a
/ Double
h' forall a. Num a => a -> a -> a
* Double
w') (SvgOptions
so forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "svgHeight" a => a
#svgHeight)

-- | Low-level conversion of a Chart to svg
svg :: Chart -> Lucid.Html ()
svg :: Chart -> Html ()
svg (BlankChart [Rect Double]
_) = forall a. Monoid a => a
mempty
svg Chart
c = forall arg result. Term arg result => Text -> arg -> result
term Text
"g" (Chart -> [Attribute]
atts Chart
c) (Chart -> Html ()
draw Chart
c)

cssText :: CssOptions -> Html ()
cssText :: CssOptions -> Html ()
cssText CssOptions
csso =
  forall arg result. TermRaw arg result => arg -> result
style_ [] forall a b. (a -> b) -> a -> b
$
    CssShapeRendering -> Text
cssShapeRendering (CssOptions
csso forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "shapeRendering" a => a
#shapeRendering)
      forall a. Semigroup a => a -> a -> a
<> (Colour, Colour) -> CssPreferColorScheme -> Text
cssPreferColorScheme (Colour
light, Colour
dark) (CssOptions
csso forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "preferColorScheme" a => a
#preferColorScheme)
      forall a. Semigroup a => a -> a -> a
<> CssOptions
csso forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "cssExtra" a => a
#cssExtra

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

-- | CSS prefer-color-scheme text snippet
cssPreferColorScheme :: (Colour, Colour) -> CssPreferColorScheme -> Text
cssPreferColorScheme :: (Colour, Colour) -> CssPreferColorScheme -> Text
cssPreferColorScheme (Colour
cl, Colour
cd) CssPreferColorScheme
PreferHud =
  [trimming|
svg {
  color-scheme: light dark;
}
{
  .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {
    fill: $hexDark;
  }
  .ticklines g, .tickglyph g, .legendBorder g {
    stroke: $hexDark;
  }
  .legendBorder g {
    fill: $hexLight;
  }
}
@media (prefers-color-scheme:dark) {
  .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {
    fill: $hexLight;
  }
  .ticklines g, .tickglyph g, .legendBorder g {
    stroke: $hexLight;
  }
  .legendBorder g {
    fill: $hexDark;
  }
}
|]
  where
    hexLight :: Text
hexLight = Colour -> Text
hex Colour
cl
    hexDark :: Text
hexDark = Colour -> Text
hex Colour
cd
cssPreferColorScheme (Colour
bglight, Colour
_) CssPreferColorScheme
PreferLight =
  [trimming|
    svg {
      color-scheme: light dark;
    }
    @media (prefers-color-scheme:dark) {
      svg {
        background-color: $c;
      }
    }
  |]
  where
    c :: Text
c = Colour -> Text
hex Colour
bglight
cssPreferColorScheme (Colour
_, Colour
bgdark) CssPreferColorScheme
PreferDark =
  [trimming|
    svg {
      color-scheme: light dark;
    }
    @media (prefers-color-scheme:light) {
      svg {
        background-color: $c;
      }
    }
  |]
  where
    c :: Text
c = Colour -> Text
hex Colour
bgdark
cssPreferColorScheme (Colour, Colour)
_ CssPreferColorScheme
PreferNormal = forall a. Monoid a => a
mempty

-- | consume the huds transforming a 'ChartSvg' to a 'ChartTree'
toChartTree :: ChartSvg -> ChartTree
toChartTree :: ChartSvg -> ChartTree
toChartTree ChartSvg
cs =
  Rect Double -> Rect Double -> [Hud] -> ChartTree -> ChartTree
runHudWith
    (ChartAspect -> ChartTree -> Rect Double
initialCanvas (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 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) ChartSvg
cs) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "charts" a => a
#charts ChartSvg
cs))
    Rect Double
db'
    [Hud]
hs'
    (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "charts" a => a
#charts ChartSvg
cs forall a. Semigroup a => a -> a -> a
<> Rect Double -> ChartTree
blank Rect Double
db')
  where
    ([Hud]
hs, Rect Double
db') = HudOptions -> Rect Double -> ([Hud], Rect Double)
toHuds (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 ChartSvg
cs) (Maybe (Rect Double) -> Rect Double
singletonGuard 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 "charts" a => a
#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
% Lens' ChartTree (Maybe (Rect Double))
box') ChartSvg
cs)
    hs' :: [Hud]
hs' =
      [Hud]
hs
        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 "extraHuds" a => a
#extraHuds ChartSvg
cs

-- | The initial canvas before applying Huds
--
-- >>> initialCanvas (FixedAspect 1.5) (unnamed [RectChart defaultRectStyle [one]])
-- Rect -0.75 0.75 -0.5 0.5
initialCanvas :: ChartAspect -> ChartTree -> CanvasBox
initialCanvas :: ChartAspect -> ChartTree -> Rect Double
initialCanvas (FixedAspect Double
a) ChartTree
_ = Double -> Rect Double
aspect Double
a
initialCanvas (CanvasAspect Double
a) ChartTree
_ = Double -> Rect Double
aspect Double
a
initialCanvas ChartAspect
ChartAspect ChartTree
cs = Maybe (Rect Double) -> Rect Double
singletonGuard 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 Lens' ChartTree (Maybe (Rect Double))
box' ChartTree
cs

-- | Render a chart using the supplied svg and hud config.
--
-- >>> chartSvg mempty
-- "<svg width=\"450.0\" height=\"300.0\" viewBox=\"-0.75 -0.5 1.5 1.0\" xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\"><style>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: #0d0d0d;\n  }\n  .ticklines g, .tickglyph g, .legendBorder g {\n    stroke: #0d0d0d;\n  }\n  .legendBorder g {\n    fill: #f0f0f0;\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: #f0f0f0;\n  }\n  .ticklines g, .tickglyph g, .legendBorder g {\n    stroke: #f0f0f0;\n  }\n  .legendBorder g {\n    fill: #0d0d0d;\n  }\n}</style><g class=\"chart\"></g><g class=\"hud\"></g></svg>"
chartSvg :: ChartSvg -> Text
chartSvg :: ChartSvg -> Text
chartSvg ChartSvg
cs = Html () -> Text
renderToText (SvgOptions -> ChartTree -> Html ()
renderToSvg (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "svgOptions" a => a
#svgOptions ChartSvg
cs) (ChartSvg -> ChartTree
toChartTree ChartSvg
cs))

-- | Write to a file.
writeChartSvg :: FilePath -> ChartSvg -> IO ()
writeChartSvg :: String -> ChartSvg -> IO ()
writeChartSvg String
fp ChartSvg
cs =
  String -> String -> IO ()
writeFile String
fp (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ ChartSvg -> Text
chartSvg ChartSvg
cs)

-- | Make Lucid Html given term and attributes
terms :: Text -> [Lucid.Attribute] -> Lucid.Html ()
terms :: Text -> [Attribute] -> Html ()
terms Text
t = forall a. With a => a -> [Attribute] -> a
with forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => Text -> HtmlT m ()
makeXmlElementNoEnd Text
t

-- | Rectangle svg
svgRect_ :: Rect Double -> Lucid.Html ()
svgRect_ :: Rect Double -> Html ()
svgRect_ (Rect Double
x Double
z Double
y Double
w) =
  Text -> [Attribute] -> Html ()
terms
    Text
"rect"
    [ Text -> Attribute
width_ (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double
z forall a. Num a => a -> a -> a
- Double
x),
      Text -> Attribute
height_ (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double
w forall a. Num a => a -> a -> a
- Double
y),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"x" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
x),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"y" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ -Double
w)
    ]

-- | Text svg
svgText_ :: TextStyle -> Text -> Point Double -> Lucid.Html ()
svgText_ :: TextStyle -> Text -> Point Double -> Html ()
svgText_ TextStyle
s Text
t p :: Point Double
p@(Point Double
x Double
y) =
  forall arg result. Term arg result => Text -> arg -> result
term
    Text
"text"
    ( [ forall arg result. Term arg result => Text -> arg -> result
term Text
"x" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
x),
        forall arg result. Term arg result => Text -> arg -> result
term Text
"y" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ -Double
y)
      ]
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Double
x' -> [forall arg result. Term arg result => Text -> arg -> result
term Text
"transform" (Double -> Point Double -> Text
toRotateText Double
x' Point Double
p)]) (TextStyle
s forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "rotation" a => a
#rotation)
    )
    (forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtmlRaw Text
t)
    forall a. Semigroup a => a -> a -> a
<> 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 TextStyle
s of
      Maybe RectStyle
Nothing -> forall a. Monoid a => a
mempty
      Just RectStyle
f -> Chart -> Html ()
svg (RectStyle -> [Rect Double] -> Chart
RectChart (RectStyle
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 TextStyle
s)) [TextStyle -> Text -> Point Double -> Rect Double
styleBoxText TextStyle
s Text
t Point Double
p])

-- | line svg
svgLine_ :: [[Point Double]] -> Lucid.Html ()
svgLine_ :: [[Point Double]] -> Html ()
svgLine_ [[Point Double]]
xss =
  forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
    (\[Point Double]
xs -> Text -> [Attribute] -> Html ()
terms Text
"polyline" [forall arg result. Term arg result => Text -> arg -> result
term Text
"points" (forall {a}. (Show a, Num a) => [Point a] -> Text
toPointsText [Point Double]
xs)]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Point Double]]
xss
  where
    toPointsText :: [Point a] -> Text
toPointsText [Point a]
xs' = Text -> [Text] -> Text
Text.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ (\(Point a
x a
y) -> String -> Text
pack (forall a. Show a => a -> String
show a
x forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-a
y))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point a]
xs'

-- | GlyphShape to svg Tree
svgShape_ :: GlyphShape -> Double -> Point Double -> Lucid.Html ()
svgShape_ :: GlyphShape -> Double -> Point Double -> Html ()
svgShape_ GlyphShape
CircleGlyph Double
s (Point Double
x Double
y) =
  Text -> [Attribute] -> Html ()
terms
    Text
"circle"
    [ forall arg result. Term arg result => Text -> arg -> result
term Text
"cx" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
x),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"cy" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ -Double
y),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"r" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ 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)
    ]
svgShape_ GlyphShape
SquareGlyph Double
s Point Double
p =
  Rect Double -> Html ()
svgRect_ (forall s. (Additive (Element s), Space s) => Element s -> s -> s
move Point Double
p ((Double
s forall a. Num a => a -> a -> a
*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Multiplicative a => a
one))
svgShape_ (RectSharpGlyph Double
x') Double
s Point Double
p =
  Rect Double -> Html ()
svgRect_ (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))
svgShape_ (RectRoundedGlyph Double
x' Double
rx Double
ry) Double
s Point Double
p =
  Text -> [Attribute] -> Html ()
terms
    Text
"rect"
    [ forall arg result. Term arg result => Text -> arg -> result
term Text
"width" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double
z forall a. Num a => a -> a -> a
- Double
x),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"height" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Double
w forall a. Num a => a -> a -> a
- Double
y),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"x" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
x),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"y" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ -Double
w),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"rx" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
rx),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"ry" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
ry)
    ]
  where
    (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)
svgShape_ (TriangleGlyph (Point Double
xa Double
ya) (Point Double
xb Double
yb) (Point Double
xc Double
yc)) Double
s Point Double
p =
  Text -> [Attribute] -> Html ()
terms
    Text
"polygon"
    [ forall arg result. Term arg result => Text -> arg -> result
term Text
"transform" (Point Double -> Text
toTranslateText Point Double
p),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"points" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (Double
s forall a. Num a => a -> a -> a
* Double
xa) forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-(Double
s forall a. Num a => a -> a -> a
* Double
ya)) forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Double
s forall a. Num a => a -> a -> a
* Double
xb) forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-(Double
s forall a. Num a => a -> a -> a
* Double
yb)) forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Double
s forall a. Num a => a -> a -> a
* Double
xc) forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-(Double
s forall a. Num a => a -> a -> a
* Double
yc)))
    ]
svgShape_ (EllipseGlyph Double
x') Double
s (Point Double
x Double
y) =
  Text -> [Attribute] -> Html ()
terms
    Text
"ellipse"
    [ forall arg result. Term arg result => Text -> arg -> result
term Text
"cx" ((String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) Double
x),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"cy" ((String -> Text
pack 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),
      forall arg result. Term arg result => Text -> arg -> result
term Text
"rx" ((String -> Text
pack 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 arg result. Term arg result => Text -> arg -> result
term Text
"ry" ((String -> Text
pack 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')
    ]
svgShape_ GlyphShape
VLineGlyph Double
s (Point Double
x Double
y) =
  Text -> [Attribute] -> Html ()
terms Text
"polyline" [forall arg result. Term arg result => Text -> arg -> result
term Text
"points" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
x forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-(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
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Double
x forall a. Semigroup a => a -> a -> a
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-(Double
y forall a. Num a => a -> a -> a
+ Double
s forall a. Fractional a => a -> a -> a
/ Double
2)))]
svgShape_ GlyphShape
HLineGlyph Double
s (Point Double
x Double
y) =
  Text -> [Attribute] -> Html ()
terms Text
"polyline" [forall arg result. Term arg result => Text -> arg -> result
term Text
"points" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (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
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-Double
y) forall a. Semigroup a => a -> a -> a
<> String
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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
<> String
"," forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-Double
y))]
svgShape_ (PathGlyph Text
path ScaleBorder
_) Double
s Point Double
p =
  Text -> [Attribute] -> Html ()
terms Text
"path" [forall arg result. Term arg result => Text -> arg -> result
term Text
"d" Text
path, forall arg result. Term arg result => Text -> arg -> result
term Text
"transform" (Point Double -> Text
toTranslateText Point Double
p forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Double -> Text
toScaleText Double
s)]

-- | GlyphStyle to svg Tree
svgGlyph_ :: GlyphStyle -> Point Double -> Lucid.Html ()
svgGlyph_ :: GlyphStyle -> Point Double -> Html ()
svgGlyph_ GlyphStyle
s Point Double
p =
  GlyphShape -> Double -> Point Double -> Html ()
svgShape_ (GlyphStyle
s forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "shape" a => a
#shape) (GlyphStyle
s forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "size" a => a
#size) Point Double
p
    forall a b. a -> (a -> b) -> b
& forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Double
r -> forall arg result. Term arg result => Text -> arg -> result
term Text
"g" [forall arg result. Term arg result => Text -> arg -> result
term Text
"transform" (Double -> Point Double -> Text
toRotateText Double
r Point Double
p)]) (GlyphStyle
s forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "rotation" a => a
#rotation)

-- | Path svg
svgPath_ :: [PathData Double] -> Lucid.Html ()
svgPath_ :: [PathData Double] -> Html ()
svgPath_ [PathData Double]
ps =
  Text -> [Attribute] -> Html ()
terms Text
"path" [forall arg result. Term arg result => Text -> arg -> result
term Text
"d" ([PathData Double] -> Text
pathDataToSvg [PathData Double]
ps)]

-- | RectStyle to Attributes
attsRect :: RectStyle -> [Lucid.Attribute]
attsRect :: RectStyle -> [Attribute]
attsRect RectStyle
o =
  [ forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-width" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ RectStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderSize" a => a
#borderSize),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ RectStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderColor" a => a
#borderColor),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ RectStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderColor" a => a
#borderColor),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ RectStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ RectStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color)
  ]

-- | TextStyle to Attributes
attsText :: TextStyle -> [Lucid.Attribute]
attsText :: TextStyle -> [Attribute]
attsText TextStyle
o =
  [ forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-width" Text
"0.0",
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke" Text
"none",
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ TextStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ TextStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"font-size" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ TextStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "size" a => a
#size),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"text-anchor" (Anchor -> Text
toTextAnchor forall a b. (a -> b) -> a -> b
$ TextStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "anchor" a => a
#anchor)
  ]
  where
    toTextAnchor :: Anchor -> Text
    toTextAnchor :: Anchor -> Text
toTextAnchor Anchor
AnchorMiddle = Text
"middle"
    toTextAnchor Anchor
AnchorStart = Text
"start"
    toTextAnchor Anchor
AnchorEnd = Text
"end"

-- | GlyphStyle to Attributes
attsGlyph :: GlyphStyle -> [Lucid.Attribute]
attsGlyph :: GlyphStyle -> [Attribute]
attsGlyph GlyphStyle
o =
  [ forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-width" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
sw),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderColor" a => a
#borderColor),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderColor" a => a
#borderColor),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color)
  ]
    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
. forall arg result. Term arg result => Text -> arg -> result
term Text
"transform" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point Double -> Text
toTranslateText) (GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "translate" a => a
#translate)
  where
    sw :: Double
sw = case GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "shape" a => a
#shape of
      PathGlyph Text
_ ScaleBorder
NoScaleBorder -> GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderSize" a => a
#borderSize
      PathGlyph Text
_ ScaleBorder
ScaleBorder -> forall a. Ord a => a -> a -> a
min Double
0.2 (GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderSize" a => a
#borderSize forall a. Fractional a => a -> a -> a
/ GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "size" a => a
#size)
      GlyphShape
_ -> GlyphStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderSize" a => a
#borderSize

-- | LineStyle to Attributes
attsLine :: LineStyle -> [Lucid.Attribute]
attsLine :: LineStyle -> [Attribute]
attsLine LineStyle
o =
  [ forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-width" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LineStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "size" a => a
#size),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ LineStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ LineStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill" Text
"none"
  ]
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\LineCap
x -> [forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-linecap" (forall s. IsString s => LineCap -> s
fromLineCap LineCap
x)]) (LineStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "linecap" a => a
#linecap)
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\LineJoin
x -> [forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-linejoin" (forall s. IsString s => LineJoin -> s
fromLineJoin LineJoin
x)]) (LineStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "linejoin" a => a
#linejoin)
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\[Double]
x -> [forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-dasharray" ([Double] -> Text
fromDashArray [Double]
x)]) (LineStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "dasharray" a => a
#dasharray)
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Double
x -> [forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-dashoffset" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
x)]) (LineStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "dashoffset" a => a
#dashoffset)

-- | PathStyle to Attributes
attsPath :: PathStyle -> [Lucid.Attribute]
attsPath :: PathStyle -> [Attribute]
attsPath PathStyle
o =
  [ forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-width" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ PathStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderSize" a => a
#borderSize),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ PathStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderColor" a => a
#borderColor),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"stroke-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ PathStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "borderColor" a => a
#borderColor),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill" (Colour -> Text
showRGB forall a b. (a -> b) -> a -> b
$ PathStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color),
    forall arg result. Term arg result => Text -> arg -> result
term Text
"fill-opacity" (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Colour -> Double
opac forall a b. (a -> b) -> a -> b
$ PathStyle
o forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "color" a => a
#color)
  ]

-- | includes a flip of the y dimension.
toTranslateText :: Point Double -> Text
toTranslateText :: Point Double -> Text
toTranslateText (Point Double
x Double
y) =
  String -> Text
pack forall a b. (a -> b) -> a -> b
$
    String
"translate(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Double
x forall a. Semigroup a => a -> a -> a
<> String
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-Double
y) forall a. Semigroup a => a -> a -> a
<> String
")"

-- | 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 -> Text
toRotateText :: Double -> Point Double -> Text
toRotateText Double
r (Point Double
x Double
y) =
  String -> Text
pack forall a b. (a -> b) -> a -> b
$
    String
"rotate(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-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
<> String
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Double
x forall a. Semigroup a => a -> a -> a
<> String
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (-Double
y) forall a. Semigroup a => a -> a -> a
<> String
")"

toScaleText :: Double -> Text
toScaleText :: Double -> Text
toScaleText Double
x =
  String -> Text
pack forall a b. (a -> b) -> a -> b
$
    String
"scale(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Double
x forall a. Semigroup a => a -> a -> a
<> String
")"

-- | SVG tag options.
--
-- >>> defaultSvgOptions
-- SvgOptions {svgHeight = 300.0, cssOptions = CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, cssExtra = ""}}
data SvgOptions = SvgOptions
  { SvgOptions -> Double
svgHeight :: Double,
    SvgOptions -> CssOptions
cssOptions :: CssOptions
  }
  deriving (SvgOptions -> SvgOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SvgOptions -> SvgOptions -> Bool
$c/= :: SvgOptions -> SvgOptions -> Bool
== :: SvgOptions -> SvgOptions -> Bool
$c== :: SvgOptions -> SvgOptions -> Bool
Eq, Int -> SvgOptions -> ShowS
[SvgOptions] -> ShowS
SvgOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SvgOptions] -> ShowS
$cshowList :: [SvgOptions] -> ShowS
show :: SvgOptions -> String
$cshow :: SvgOptions -> String
showsPrec :: Int -> SvgOptions -> ShowS
$cshowsPrec :: Int -> SvgOptions -> ShowS
Show, forall x. Rep SvgOptions x -> SvgOptions
forall x. SvgOptions -> Rep SvgOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SvgOptions x -> SvgOptions
$cfrom :: forall x. SvgOptions -> Rep SvgOptions x
Generic)

-- | The official svg options
defaultSvgOptions :: SvgOptions
defaultSvgOptions :: SvgOptions
defaultSvgOptions = Double -> CssOptions -> SvgOptions
SvgOptions Double
300 CssOptions
defaultCssOptions

-- | CSS shape rendering options
data CssShapeRendering = UseGeometricPrecision | UseCssCrisp | NoShapeRendering deriving (Int -> CssShapeRendering -> ShowS
[CssShapeRendering] -> ShowS
CssShapeRendering -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CssShapeRendering] -> ShowS
$cshowList :: [CssShapeRendering] -> ShowS
show :: CssShapeRendering -> String
$cshow :: CssShapeRendering -> String
showsPrec :: Int -> CssShapeRendering -> ShowS
$cshowsPrec :: Int -> CssShapeRendering -> ShowS
Show, CssShapeRendering -> CssShapeRendering -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CssShapeRendering -> CssShapeRendering -> Bool
$c/= :: CssShapeRendering -> CssShapeRendering -> Bool
== :: CssShapeRendering -> CssShapeRendering -> Bool
$c== :: CssShapeRendering -> CssShapeRendering -> Bool
Eq, forall x. Rep CssShapeRendering x -> CssShapeRendering
forall x. CssShapeRendering -> Rep CssShapeRendering x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CssShapeRendering x -> CssShapeRendering
$cfrom :: forall x. CssShapeRendering -> Rep CssShapeRendering x
Generic)

-- | CSS prefer-color-scheme options
data CssPreferColorScheme
  = -- | includes css that switches approriate hud elements between light and dark.
    PreferHud
  | PreferDark
  | PreferLight
  | PreferNormal
  deriving (Int -> CssPreferColorScheme -> ShowS
[CssPreferColorScheme] -> ShowS
CssPreferColorScheme -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CssPreferColorScheme] -> ShowS
$cshowList :: [CssPreferColorScheme] -> ShowS
show :: CssPreferColorScheme -> String
$cshow :: CssPreferColorScheme -> String
showsPrec :: Int -> CssPreferColorScheme -> ShowS
$cshowsPrec :: Int -> CssPreferColorScheme -> ShowS
Show, CssPreferColorScheme -> CssPreferColorScheme -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CssPreferColorScheme -> CssPreferColorScheme -> Bool
$c/= :: CssPreferColorScheme -> CssPreferColorScheme -> Bool
== :: CssPreferColorScheme -> CssPreferColorScheme -> Bool
$c== :: CssPreferColorScheme -> CssPreferColorScheme -> Bool
Eq, forall x. Rep CssPreferColorScheme x -> CssPreferColorScheme
forall x. CssPreferColorScheme -> Rep CssPreferColorScheme x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CssPreferColorScheme x -> CssPreferColorScheme
$cfrom :: forall x. CssPreferColorScheme -> Rep CssPreferColorScheme x
Generic)

-- | css options
--
-- >>> defaultCssOptions
-- CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, cssExtra = ""}
data CssOptions = CssOptions {CssOptions -> CssShapeRendering
shapeRendering :: CssShapeRendering, CssOptions -> CssPreferColorScheme
preferColorScheme :: CssPreferColorScheme, CssOptions -> Text
cssExtra :: Text} 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 = CssShapeRendering -> CssPreferColorScheme -> Text -> CssOptions
CssOptions CssShapeRendering
NoShapeRendering CssPreferColorScheme
PreferHud forall a. Monoid a => a
mempty