{-# LANGUAGE CPP               #-}
{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE DeriveDataTypeable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.SVG
-- Copyright   :  (c) 2011 diagrams-svg team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Generic tools for generating SVG files.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.SVG
    ( SVGFloat
    , Element
    , AttributeValue
    , svgHeader
    , renderPath
    , renderClip
    , renderText
    , renderDImage
    , renderDImageEmb
    , renderStyles
    , renderMiterLimit
    , renderFillTextureDefs
    , renderFillTexture
    , renderLineTextureDefs
    , renderLineTexture
    , dataUri
    , getNumAttr
    ) where

-- from base
import           Data.List                   (intercalate)
#if __GLASGOW_HASKELL__ < 710
import           Data.Foldable               (foldMap)
#endif

import           Data.Maybe                  (fromMaybe)
#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid
#endif

-- from diagrams-core
import           Diagrams.Core.Transform     (matrixHomRep)

-- from diagrams-lib
import           Diagrams.Prelude            hiding (Attribute, Render, with, (<>))
import           Diagrams.TwoD.Path          (getFillRule)
import           Diagrams.TwoD.Text

-- from text
import           Data.Text                   (pack)
import qualified Data.Text                   as T

-- from lucid-svg
import           Graphics.Svg                hiding (renderText)

-- from base64-bytestring, bytestring
import qualified Data.ByteString.Base64.Lazy as BS64
import qualified Data.ByteString.Lazy.Char8  as BS8

-- from JuicyPixels
import           Codec.Picture

-- | Constaint on number type that diagrams-svg can use to render an SVG. This
--   includes the common number types: Double, Float
type SVGFloat n = (Show n, TypeableFloat n)
-- Could we change Text.Blaze.SVG to use
--   showFFloat :: RealFloat a => Maybe Int -> a -> ShowS
-- or something similar for all numbers so we need TypeableFloat constraint.

type AttributeValue = T.Text

getNumAttr :: AttributeClass (a n) => (a n -> t) -> Style v n -> Maybe t
getNumAttr :: (a n -> t) -> Style v n -> Maybe t
getNumAttr a n -> t
f = (a n -> t
f (a n -> t) -> Maybe (a n) -> Maybe t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe (a n) -> Maybe t)
-> (Style v n -> Maybe (a n)) -> Style v n -> Maybe t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style v n -> Maybe (a n)
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr

-- | @svgHeader w h defs s@: @w@ width, @h@ height,
--   @defs@ global definitions for defs sections, @s@ actual SVG content.
svgHeader :: SVGFloat n => n -> n -> Maybe Element -> [Attribute] -> Bool
                        -> Element -> Element
svgHeader :: n
-> n -> Maybe Element -> [Attribute] -> Bool -> Element -> Element
svgHeader n
w n
h Maybe Element
defines [Attribute]
attributes Bool
genDoctype Element
s =
  Element
dt Element -> Element -> Element
forall a. Semigroup a => a -> a -> a
<> Element -> [Attribute] -> Element
with (Element -> Element
svg11_ ([Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] Element
ds Element -> Element -> Element
forall a. Semigroup a => a -> a -> a
<> Element
s))
    ([ AttrTag
Width_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
w
     , AttrTag
Height_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
h
     , AttrTag
Font_size_ AttrTag -> Text -> Attribute
<<- Text
"1"
     , AttrTag
ViewBox_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ (n -> String) -> [n] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map n -> String
forall a. Show a => a -> String
show [n
0, n
0, n
w, n
h])
     , AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- Text
"rgb(0,0,0)"
     , AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1" ]
     [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Attribute]
attributes )
  where
    ds :: Element
ds = Element -> Maybe Element -> Element
forall a. a -> Maybe a -> a
fromMaybe Element
forall a. Monoid a => a
mempty Maybe Element
defines
    dt :: Element
dt = if Bool
genDoctype then Element
doctype else Element
forall a. Monoid a => a
mempty

renderPath :: SVGFloat n => Path V2 n -> Element
renderPath :: Path V2 n -> Element
renderPath Path V2 n
trs = if Text
makePath Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty then Element
forall a. Monoid a => a
mempty else [Attribute] -> Element
forall result. Term result => [Attribute] -> result
path_ [AttrTag
D_ AttrTag -> Text -> Attribute
<<- Text
makePath]
  where
    makePath :: Text
makePath = (Located (Trail V2 n) -> Text) -> [Located (Trail V2 n)] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Located (Trail V2 n) -> Text
forall n. SVGFloat n => Located (Trail V2 n) -> Text
renderTrail ((Unwrapped (Path V2 n) -> Path V2 n)
-> Path V2 n -> Unwrapped (Path V2 n)
forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op Unwrapped (Path V2 n) -> Path V2 n
forall (v :: * -> *) n. [Located (Trail v n)] -> Path v n
Path Path V2 n
trs)

renderTrail :: SVGFloat n => Located (Trail V2 n) -> AttributeValue
renderTrail :: Located (Trail V2 n) -> Text
renderTrail (Located (Trail V2 n)
-> (Point (V (Trail V2 n)) (N (Trail V2 n)), Trail V2 n)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (P (V2 x y), Trail V2 n
t)) =
  n -> n -> Text
forall a. RealFloat a => a -> a -> Text
mA n
x n
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Trail' Line V2 n -> Text)
-> (Trail' Loop V2 n -> Text) -> Trail V2 n -> Text
forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line V2 n -> Text
renderLine Trail' Loop V2 n -> Text
forall n.
(Show n, Typeable n, RealFloat n) =>
Trail' Loop V2 n -> Text
renderLoop Trail V2 n
t
  where
    renderLine :: Trail' Line V2 n -> Text
renderLine = (Segment Closed V2 n -> Text) -> [Segment Closed V2 n] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> Text
forall n. SVGFloat n => Segment Closed V2 n -> Text
renderSeg ([Segment Closed V2 n] -> Text)
-> (Trail' Line V2 n -> [Segment Closed V2 n])
-> Trail' Line V2 n
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Line V2 n -> [Segment Closed V2 n]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments
    renderLoop :: Trail' Loop V2 n -> Text
renderLoop Trail' Loop V2 n
lp =
      case Trail' Loop V2 n -> ([Segment Closed V2 n], Segment Open V2 n)
forall (v :: * -> *) n.
Trail' Loop v n -> ([Segment Closed v n], Segment Open v n)
loopSegments Trail' Loop V2 n
lp of
        -- let z handle the last segment if it is linear
        ([Segment Closed V2 n]
segs, Linear Offset Open V2 n
_) -> (Segment Closed V2 n -> Text) -> [Segment Closed V2 n] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> Text
forall n. SVGFloat n => Segment Closed V2 n -> Text
renderSeg [Segment Closed V2 n]
segs

        -- otherwise we have to emit it explicitly
        ([Segment Closed V2 n], Segment Open V2 n)
_ -> (Segment Closed V2 n -> Text) -> [Segment Closed V2 n] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> Text
forall n. SVGFloat n => Segment Closed V2 n -> Text
renderSeg (Trail' Line V2 n -> [Segment Closed V2 n]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments (Trail' Line V2 n -> [Segment Closed V2 n])
-> (Trail' Loop V2 n -> Trail' Line V2 n)
-> Trail' Loop V2 n
-> [Segment Closed V2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Loop V2 n -> Trail' Line V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop (Trail' Loop V2 n -> [Segment Closed V2 n])
-> Trail' Loop V2 n -> [Segment Closed V2 n]
forall a b. (a -> b) -> a -> b
$ Trail' Loop V2 n
lp)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
z

renderSeg :: SVGFloat n => Segment Closed V2 n -> AttributeValue
renderSeg :: Segment Closed V2 n -> Text
renderSeg (Linear (OffsetClosed (V2 n
x n
0))) = n -> Text
forall a. RealFloat a => a -> Text
hR n
x
renderSeg (Linear (OffsetClosed (V2 n
0 n
y))) = n -> Text
forall a. RealFloat a => a -> Text
vR n
y
renderSeg (Linear (OffsetClosed (V2 n
x n
y))) = n -> n -> Text
forall a. RealFloat a => a -> a -> Text
lR n
x n
y
renderSeg (Cubic  (V2 n
x0 n
y0)
                  (V2 n
x1 n
y1)
                  (OffsetClosed (V2 n
x2 n
y2))) = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
cR n
x0 n
y0 n
x1 n
y1 n
x2 n
y2

renderClip :: SVGFloat n => Path V2 n -> T.Text -> Int -> Element -> Element
renderClip :: Path V2 n -> Text -> Int -> Element -> Element
renderClip Path V2 n
p Text
prefix Int
ident Element
svg = do
     [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
clipPath_ [AttrTag
Id_ AttrTag -> Text -> Attribute
<<- (Int -> Text
clipPathId Int
ident)] (Path V2 n -> Element
forall n. SVGFloat n => Path V2 n -> Element
renderPath Path V2 n
p)
  Element -> Element -> Element
forall a. Semigroup a => a -> a -> a
<> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_  [AttrTag
Clip_path_ AttrTag -> Text -> Attribute
<<- (Text
"url(#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
clipPathId Int
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")] Element
svg
    where
      clipPathId :: Int -> Text
clipPathId Int
i = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"myClip" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
i)

renderStop :: SVGFloat n => GradientStop n -> Element
renderStop :: GradientStop n -> Element
renderStop (GradientStop SomeColor
c n
v)
  = [Attribute] -> Element
forall result. Term result => [Attribute] -> result
stop_ [ AttrTag
Stop_color_ AttrTag -> Text -> Attribute
<<- (SomeColor -> Text
forall c. Color c => c -> Text
colorToRgbText SomeColor
c)
          , AttrTag
Offset_ AttrTag -> Text -> Attribute
<<- (n -> Text
forall a. RealFloat a => a -> Text
toText n
v)
          , AttrTag
Stop_opacity_ AttrTag -> Text -> Attribute
<<- (Double -> Text
forall a. RealFloat a => a -> Text
toText (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ SomeColor -> Double
forall c. Color c => c -> Double
colorToOpacity SomeColor
c) ]

spreadMethodText :: SpreadMethod -> AttributeValue
spreadMethodText :: SpreadMethod -> Text
spreadMethodText SpreadMethod
GradPad      = Text
"pad"
spreadMethodText SpreadMethod
GradReflect  = Text
"reflect"
spreadMethodText SpreadMethod
GradRepeat   = Text
"repeat"

renderLinearGradient :: SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient :: LGradient n -> Int -> Element
renderLinearGradient LGradient n
g Int
i = [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
linearGradient_
    [ AttrTag
Id_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"gradient" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
    , AttrTag
X1_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
x1
    , AttrTag
Y1_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
y1
    , AttrTag
X2_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
x2
    , AttrTag
Y2_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
y2
    , AttrTag
GradientTransform_ AttrTag -> Text -> Attribute
<<- Text
mx
    , AttrTag
GradientUnits_ AttrTag -> Text -> Attribute
<<- Text
"userSpaceOnUse"
    , AttrTag
SpreadMethod_ AttrTag -> Text -> Attribute
<<- SpreadMethod -> Text
spreadMethodText (LGradient n
g LGradient n
-> Getting SpreadMethod (LGradient n) SpreadMethod -> SpreadMethod
forall s a. s -> Getting a s a -> a
^. Getting SpreadMethod (LGradient n) SpreadMethod
forall n. Lens' (LGradient n) SpreadMethod
lGradSpreadMethod) ]
    (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ (GradientStop n -> Element) -> [GradientStop n] -> Element
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GradientStop n -> Element
forall n. SVGFloat n => GradientStop n -> Element
renderStop (LGradient n
gLGradient n
-> Getting [GradientStop n] (LGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^.Getting [GradientStop n] (LGradient n) [GradientStop n]
forall n. Lens' (LGradient n) [GradientStop n]
lGradStops)
  where
    mx :: Text
mx = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a1 n
a2 n
b1 n
b2 n
c1 n
c2
    [[n
a1, n
a2], [n
b1, n
b2], [n
c1, n
c2]] = Transformation V2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (LGradient n
g LGradient n
-> Getting
     (Transformation V2 n) (LGradient n) (Transformation V2 n)
-> Transformation V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Transformation V2 n) (LGradient n) (Transformation V2 n)
forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans)
    P (V2 n
x1 n
y1) = LGradient n
g LGradient n
-> Getting (Point V2 n) (LGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (LGradient n) (Point V2 n)
forall n. Lens' (LGradient n) (Point V2 n)
lGradStart
    P (V2 n
x2 n
y2) = LGradient n
g LGradient n
-> Getting (Point V2 n) (LGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (LGradient n) (Point V2 n)
forall n. Lens' (LGradient n) (Point V2 n)
lGradEnd

renderRadialGradient :: SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient :: RGradient n -> Int -> Element
renderRadialGradient RGradient n
g Int
i = [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
radialGradient_
    [ AttrTag
Id_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"gradient" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
    , AttrTag
R_  AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText (RGradient n
g RGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius1)
    , AttrTag
Cx_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
cx
    , AttrTag
Cy_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
cy
    , AttrTag
Fx_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
fx
    , AttrTag
Fy_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
fy
    , AttrTag
GradientTransform_ AttrTag -> Text -> Attribute
<<- Text
mx
    , AttrTag
GradientUnits_ AttrTag -> Text -> Attribute
<<- Text
"userSpaceOnUse"
    , AttrTag
SpreadMethod_ AttrTag -> Text -> Attribute
<<- SpreadMethod -> Text
spreadMethodText (RGradient n
g RGradient n
-> Getting SpreadMethod (RGradient n) SpreadMethod -> SpreadMethod
forall s a. s -> Getting a s a -> a
^. Getting SpreadMethod (RGradient n) SpreadMethod
forall n. Lens' (RGradient n) SpreadMethod
rGradSpreadMethod) ]
    ( (GradientStop n -> Element) -> [GradientStop n] -> Element
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GradientStop n -> Element
forall n. SVGFloat n => GradientStop n -> Element
renderStop [GradientStop n]
ss )
  where
    mx :: Text
mx = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a1 n
a2 n
b1 n
b2 n
c1 n
c2
    [[n
a1, n
a2], [n
b1, n
b2], [n
c1, n
c2]] = Transformation V2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (RGradient n
g RGradient n
-> Getting
     (Transformation V2 n) (RGradient n) (Transformation V2 n)
-> Transformation V2 n
forall s a. s -> Getting a s a -> a
^.Getting (Transformation V2 n) (RGradient n) (Transformation V2 n)
forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans)
    P (V2 n
cx n
cy) = RGradient n
g RGradient n
-> Getting (Point V2 n) (RGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (RGradient n) (Point V2 n)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter1
    P (V2 n
fx n
fy) = RGradient n
g RGradient n
-> Getting (Point V2 n) (RGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (RGradient n) (Point V2 n)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter0 -- SVGs focal point is our inner center.

    -- Adjust the stops so that the gradient begins at the perimeter of
    -- the inner circle (center0, radius0) and ends at the outer circle.
    r0 :: n
r0 = RGradient n
g RGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius0
    r1 :: n
r1 = RGradient n
g RGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius1
    stopFracs :: [n]
stopFracs = n
r0 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
r1 n -> [n] -> [n]
forall a. a -> [a] -> [a]
: (GradientStop n -> n) -> [GradientStop n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (\GradientStop n
s -> (n
r0 n -> n -> n
forall a. Num a => a -> a -> a
+ (GradientStop n
s GradientStop n -> Getting n (GradientStop n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (GradientStop n) n
forall n. Lens' (GradientStop n) n
stopFraction) n -> n -> n
forall a. Num a => a -> a -> a
* (n
r1 n -> n -> n
forall a. Num a => a -> a -> a
- n
r0)) n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
r1)
                (RGradient n
g RGradient n
-> Getting [GradientStop n] (RGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^. Getting [GradientStop n] (RGradient n) [GradientStop n]
forall n. Lens' (RGradient n) [GradientStop n]
rGradStops)
    gradStops :: [GradientStop n]
gradStops = case RGradient n
g RGradient n
-> Getting [GradientStop n] (RGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^. Getting [GradientStop n] (RGradient n) [GradientStop n]
forall n. Lens' (RGradient n) [GradientStop n]
rGradStops of
      []       -> []
      xs :: [GradientStop n]
xs@(GradientStop n
x:[GradientStop n]
_) -> GradientStop n
x GradientStop n -> [GradientStop n] -> [GradientStop n]
forall a. a -> [a] -> [a]
: [GradientStop n]
xs
    ss :: [GradientStop n]
ss = (GradientStop n -> n -> GradientStop n)
-> [GradientStop n] -> [n] -> [GradientStop n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\GradientStop n
gs n
sf -> GradientStop n
gs GradientStop n
-> (GradientStop n -> GradientStop n) -> GradientStop n
forall a b. a -> (a -> b) -> b
& (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction ((n -> Identity n) -> GradientStop n -> Identity (GradientStop n))
-> n -> GradientStop n -> GradientStop n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
sf ) [GradientStop n]
gradStops [n]
stopFracs

-- Create a gradient element so that it can be used as an attribute value for fill.
renderFillTextureDefs :: SVGFloat n => Int -> Style v n -> Element
renderFillTextureDefs :: Int -> Style v n -> Element
renderFillTextureDefs Int
i Style v n
s =
  case (FillTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr FillTexture n -> Texture n
forall n. FillTexture n -> Texture n
getFillTexture Style v n
s of
    Just (LG LGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ LGradient n -> Int -> Element
forall n. SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient LGradient n
g Int
i
    Just (RG RGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ RGradient n -> Int -> Element
forall n. SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient RGradient n
g Int
i
    Maybe (Texture n)
_           -> Element
forall a. Monoid a => a
mempty

-- Render the gradient using the id set up in renderFillTextureDefs.
renderFillTexture :: SVGFloat n => Int -> Style v n -> [Attribute]
renderFillTexture :: Int -> Style v n -> [Attribute]
renderFillTexture Int
ident Style v n
s = case (FillTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr FillTexture n -> Texture n
forall n. FillTexture n -> Texture n
getFillTexture Style v n
s of
  Just (SC (SomeColor c
c)) -> AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Fill_ Maybe Text
fillColorRgb [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<>
                             AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Fill_opacity_ Maybe Double
fillColorOpacity
    where
      fillColorRgb :: Maybe Text
fillColorRgb     = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ c -> Text
forall c. Color c => c -> Text
colorToRgbText c
c
      fillColorOpacity :: Maybe Double
fillColorOpacity = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ c -> Double
forall c. Color c => c -> Double
colorToOpacity c
c
  Just (LG LGradient n
_) -> [AttrTag
Fill_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Fill_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
  Just (RG RGradient n
_) -> [AttrTag
Fill_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Fill_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
  Maybe (Texture n)
Nothing     -> []

renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> Element
renderLineTextureDefs :: Int -> Style v n -> Element
renderLineTextureDefs Int
i Style v n
s =
  case (LineTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr LineTexture n -> Texture n
forall n. LineTexture n -> Texture n
getLineTexture Style v n
s of
    Just (LG LGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ LGradient n -> Int -> Element
forall n. SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient LGradient n
g Int
i
    Just (RG RGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ RGradient n -> Int -> Element
forall n. SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient RGradient n
g Int
i
    Maybe (Texture n)
_           -> Element
forall a. Monoid a => a
mempty

renderLineTexture :: SVGFloat n => Int -> Style v n -> [Attribute]
renderLineTexture :: Int -> Style v n -> [Attribute]
renderLineTexture Int
ident Style v n
s = case (LineTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr LineTexture n -> Texture n
forall n. LineTexture n -> Texture n
getLineTexture Style v n
s of
  Just (SC (SomeColor c
c)) -> AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_ Maybe Text
lineColorRgb [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<>
                             AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_opacity_ Maybe Double
lineColorOpacity
    where
      lineColorRgb :: Maybe Text
lineColorRgb     = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ c -> Text
forall c. Color c => c -> Text
colorToRgbText c
c
      lineColorOpacity :: Maybe Double
lineColorOpacity = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ c -> Double
forall c. Color c => c -> Double
colorToOpacity c
c
  Just (LG LGradient n
_) -> [AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
  Just (RG RGradient n
_) -> [AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
  Maybe (Texture n)
Nothing     -> []

dataUri :: String -> BS8.ByteString -> AttributeValue
dataUri :: String -> ByteString -> Text
dataUri String
mime ByteString
dat = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"data:"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mimeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";base64," String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS8.unpack (ByteString -> ByteString
BS64.encode ByteString
dat)

renderDImageEmb :: SVGFloat n => DImage n Embedded -> Element
renderDImageEmb :: DImage n Embedded -> Element
renderDImageEmb di :: DImage n Embedded
di@(DImage (ImageRaster DynamicImage
dImg) Int
_ Int
_ Transformation V2 n
_) =
  DImage n Embedded -> Text -> Element
forall n any. SVGFloat n => DImage n any -> Text -> Element
renderDImage DImage n Embedded
di (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Text
dataUri String
"image/png" ByteString
img
  where
    img :: ByteString
img = case DynamicImage -> Either String ByteString
encodeDynamicPng DynamicImage
dImg of
            Left String
str   -> String -> ByteString
forall a. HasCallStack => String -> a
error String
str
            Right ByteString
img' -> ByteString
img'

renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> Element
renderDImage :: DImage n any -> Text -> Element
renderDImage (DImage ImageData any
_ Int
w Int
h Transformation V2 n
tr) Text
uridata =
  [Attribute] -> Element
forall result. Term result => [Attribute] -> result
image_
    [ AttrTag
Transform_ AttrTag -> Text -> Attribute
<<- Text
transformMatrix
    , AttrTag
Width_ AttrTag -> Text -> Attribute
<<-  (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
w)
    , AttrTag
Height_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
h)
    , AttrTag
XlinkHref_ AttrTag -> Text -> Attribute
<<- Text
uridata ]
  where
    [[n
a,n
b],[n
c,n
d],[n
e,n
f]] = Transformation V2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (Transformation V2 n
tr Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Monoid a => a -> a -> a
`mappend` Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY
                                           Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Monoid a => a -> a -> a
`mappend` Transformation V2 n
tX Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Monoid a => a -> a -> a
`mappend` Transformation V2 n
tY)
    transformMatrix :: Text
transformMatrix = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a n
b n
c n
d n
e n
f
    tX :: Transformation V2 n
tX = n -> Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R1 v, Num n) =>
n -> Transformation v n
translationX (n -> Transformation V2 n) -> n -> Transformation V2 n
forall a b. (a -> b) -> a -> b
$ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
w)n -> n -> n
forall a. Fractional a => a -> a -> a
/n
2
    tY :: Transformation V2 n
tY = n -> Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
n -> Transformation v n
translationY (n -> Transformation V2 n) -> n -> Transformation V2 n
forall a b. (a -> b) -> a -> b
$ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
h)n -> n -> n
forall a. Fractional a => a -> a -> a
/n
2

renderText :: SVGFloat n => Text n -> Element
renderText :: Text n -> Element
renderText (Text T2 n
tt TextAlignment n
tAlign String
str) =
  [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
text_
    [ AttrTag
Transform_ AttrTag -> Text -> Attribute
<<- Text
transformMatrix
    , AttrTag
Dominant_baseline_ AttrTag -> Text -> Attribute
<<- Text
vAlign
    , AttrTag
Text_anchor_ AttrTag -> Text -> Attribute
<<- Text
hAlign
    , AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- Text
"none" ]
    (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element
forall a. ToElement a => a -> Element
toElement String
str
 where
  vAlign :: Text
vAlign = case TextAlignment n
tAlign of
             TextAlignment n
BaselineText -> Text
"alphabetic"
             BoxAlignedText n
_ n
h -> case n
h of -- A mere approximation
               n
h' | n
h' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
0.25 -> Text
"text-after-edge"
               n
h' | n
h' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0.75 -> Text
"text-before-edge"
               n
_ -> Text
"middle"
  hAlign :: Text
hAlign = case TextAlignment n
tAlign of
             TextAlignment n
BaselineText -> Text
"start"
             BoxAlignedText n
w n
_ -> case n
w of -- A mere approximation
               n
w' | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
0.25 -> Text
"start"
               n
w' | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0.75 -> Text
"end"
               n
_ -> Text
"middle"
  t :: T2 n
t                   = T2 n
tt T2 n -> T2 n -> T2 n
forall a. Monoid a => a -> a -> a
`mappend` T2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY
  [[n
a,n
b],[n
c,n
d],[n
e,n
f]] = T2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep T2 n
t
  transformMatrix :: Text
transformMatrix     = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a n
b n
c n
d n
e n
f

renderStyles :: SVGFloat n => Int -> Int -> Style v n -> [Attribute]
renderStyles :: Int -> Int -> Style v n -> [Attribute]
renderStyles Int
fillId Int
lineId Style v n
s = ((Style v n -> [Attribute]) -> [Attribute])
-> [Style v n -> [Attribute]] -> [Attribute]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Style v n -> [Attribute]) -> Style v n -> [Attribute]
forall a b. (a -> b) -> a -> b
$ Style v n
s) ([Style v n -> [Attribute]] -> [Attribute])
-> [Style v n -> [Attribute]] -> [Attribute]
forall a b. (a -> b) -> a -> b
$
  [ Int -> Style v n -> [Attribute]
forall n (v :: * -> *).
SVGFloat n =>
Int -> Style v n -> [Attribute]
renderLineTexture Int
lineId
  , Int -> Style v n -> [Attribute]
forall n (v :: * -> *).
SVGFloat n =>
Int -> Style v n -> [Attribute]
renderFillTexture Int
fillId
  , Style v n -> [Attribute]
forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderLineWidth
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderLineCap
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderLineJoin
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFillRule
  , Style v n -> [Attribute]
forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderDashing
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderOpacity
  , Style v n -> [Attribute]
forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderFontSize
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontSlant
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontWeight
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontFamily
  , Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderMiterLimit ]

renderMiterLimit :: Style v n -> [Attribute]
renderMiterLimit :: Style v n -> [Attribute]
renderMiterLimit Style v n
s = AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_miterlimit_ Maybe Double
miterLimit
 where miterLimit :: Maybe Double
miterLimit = LineMiterLimit -> Double
getLineMiterLimit (LineMiterLimit -> Double) -> Maybe LineMiterLimit -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe LineMiterLimit
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s

renderOpacity :: Style v n -> [Attribute]
renderOpacity :: Style v n -> [Attribute]
renderOpacity Style v n
s = AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Opacity_ Maybe Double
o
 where o :: Maybe Double
o = Opacity -> Double
getOpacity (Opacity -> Double) -> Maybe Opacity -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe Opacity
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s

renderFillRule :: Style v n -> [Attribute]
renderFillRule :: Style v n -> [Attribute]
renderFillRule Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Fill_rule_ Maybe Text
fr
  where fr :: Maybe Text
fr = (FillRule -> Text
fillRuleToText (FillRule -> Text) -> (FillRule -> FillRule) -> FillRule -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> FillRule
getFillRule) (FillRule -> Text) -> Maybe FillRule -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe FillRule
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
        fillRuleToText :: FillRule -> AttributeValue
        fillRuleToText :: FillRule -> Text
fillRuleToText FillRule
Winding = Text
"nonzero"
        fillRuleToText FillRule
EvenOdd = Text
"evenodd"

renderLineWidth :: SVGFloat n => Style v n -> [Attribute]
renderLineWidth :: Style v n -> [Attribute]
renderLineWidth Style v n
s = AttrTag -> Maybe n -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_width_ Maybe n
lWidth
  where lWidth :: Maybe n
lWidth = (LineWidth n -> n) -> Style v n -> Maybe n
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr LineWidth n -> n
forall n. LineWidth n -> n
getLineWidth Style v n
s

renderLineCap :: Style v n -> [Attribute]
renderLineCap :: Style v n -> [Attribute]
renderLineCap Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_linecap_ Maybe Text
lCap
  where lCap :: Maybe Text
lCap = (LineCap -> Text
lineCapToText (LineCap -> Text) -> (LineCap -> LineCap) -> LineCap -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap) (LineCap -> Text) -> Maybe LineCap -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe LineCap
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
        lineCapToText :: LineCap -> AttributeValue
        lineCapToText :: LineCap -> Text
lineCapToText LineCap
LineCapButt   = Text
"butt"
        lineCapToText LineCap
LineCapRound  = Text
"round"
        lineCapToText LineCap
LineCapSquare = Text
"square"

renderLineJoin :: Style v n -> [Attribute]
renderLineJoin :: Style v n -> [Attribute]
renderLineJoin Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_linejoin_ Maybe Text
lj
  where lj :: Maybe Text
lj = (LineJoin -> Text
lineJoinToText (LineJoin -> Text) -> (LineJoin -> LineJoin) -> LineJoin -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin) (LineJoin -> Text) -> Maybe LineJoin -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe LineJoin
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
        lineJoinToText :: LineJoin -> AttributeValue
        lineJoinToText :: LineJoin -> Text
lineJoinToText LineJoin
LineJoinMiter = Text
"miter"
        lineJoinToText LineJoin
LineJoinRound = Text
"round"
        lineJoinToText LineJoin
LineJoinBevel = Text
"bevel"

renderDashing :: SVGFloat n => Style v n -> [Attribute]
renderDashing :: Style v n -> [Attribute]
renderDashing Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_dasharray_ Maybe Text
arr [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<>
                  AttrTag -> Maybe n -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_dashoffset_ Maybe n
dOffset
 where
  getDasharray :: Dashing n -> [n]
getDasharray  (Dashing [n]
a n
_) = [n]
a
  getDashoffset :: Dashing n -> n
getDashoffset (Dashing [n]
_ n
o) = n
o
  dashArrayToStr :: [n] -> String
dashArrayToStr = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> ([n] -> [String]) -> [n] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> String) -> [n] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map n -> String
forall a. Show a => a -> String
show
  -- Ignore dashing if dashing array is empty
  checkEmpty :: Maybe (Dashing n) -> Maybe (Dashing n)
checkEmpty (Just (Dashing [] n
_)) = Maybe (Dashing n)
forall a. Maybe a
Nothing
  checkEmpty Maybe (Dashing n)
other = Maybe (Dashing n)
other
  dashing' :: Maybe (Dashing n)
dashing' = Maybe (Dashing n) -> Maybe (Dashing n)
forall n. Maybe (Dashing n) -> Maybe (Dashing n)
checkEmpty (Maybe (Dashing n) -> Maybe (Dashing n))
-> Maybe (Dashing n) -> Maybe (Dashing n)
forall a b. (a -> b) -> a -> b
$ (Dashing n -> Dashing n) -> Style v n -> Maybe (Dashing n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr Dashing n -> Dashing n
forall n. Dashing n -> Dashing n
getDashing Style v n
s
  arr :: Maybe Text
arr = (String -> Text
pack (String -> Text) -> (Dashing n -> String) -> Dashing n -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [n] -> String
dashArrayToStr ([n] -> String) -> (Dashing n -> [n]) -> Dashing n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dashing n -> [n]
forall n. Dashing n -> [n]
getDasharray) (Dashing n -> Text) -> Maybe (Dashing n) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Dashing n)
dashing'
  dOffset :: Maybe n
dOffset = Dashing n -> n
forall n. Dashing n -> n
getDashoffset (Dashing n -> n) -> Maybe (Dashing n) -> Maybe n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Dashing n)
dashing'

renderFontSize :: SVGFloat n => Style v n -> [Attribute]
renderFontSize :: Style v n -> [Attribute]
renderFontSize Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_size_ Maybe Text
fs
 where
  fs :: Maybe Text
fs = String -> Text
pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FontSize n -> String) -> Style v n -> Maybe String
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"px") (String -> String)
-> (FontSize n -> String) -> FontSize n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> String
forall a. Show a => a -> String
show (n -> String) -> (FontSize n -> n) -> FontSize n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSize n -> n
forall n. FontSize n -> n
getFontSize) Style v n
s

renderFontSlant :: Style v n -> [Attribute]
renderFontSlant :: Style v n -> [Attribute]
renderFontSlant Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_style_ Maybe Text
fs
 where
  fs :: Maybe Text
fs = (FontSlant -> Text
fontSlantAttr (FontSlant -> Text)
-> (FontSlant -> FontSlant) -> FontSlant -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSlant -> FontSlant
getFontSlant) (FontSlant -> Text) -> Maybe FontSlant -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe FontSlant
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
  fontSlantAttr :: FontSlant -> AttributeValue
  fontSlantAttr :: FontSlant -> Text
fontSlantAttr FontSlant
FontSlantItalic  = Text
"italic"
  fontSlantAttr FontSlant
FontSlantOblique = Text
"oblique"
  fontSlantAttr FontSlant
FontSlantNormal  = Text
"normal"

renderFontWeight :: Style v n -> [Attribute]
renderFontWeight :: Style v n -> [Attribute]
renderFontWeight Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_weight_ Maybe Text
fw
 where
  fw :: Maybe Text
fw = (FontWeight -> Text
fontWeightAttr (FontWeight -> Text)
-> (FontWeight -> FontWeight) -> FontWeight -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontWeight -> FontWeight
getFontWeight) (FontWeight -> Text) -> Maybe FontWeight -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe FontWeight
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
  fontWeightAttr :: FontWeight -> AttributeValue
  fontWeightAttr :: FontWeight -> Text
fontWeightAttr FontWeight
FontWeightNormal = Text
"normal"
  fontWeightAttr FontWeight
FontWeightBold   = Text
"bold"
  fontWeightAttr FontWeight
FontWeightLighter = Text
"lighter"
  fontWeightAttr FontWeight
FontWeightBolder  = Text
"bolder"
  fontWeightAttr FontWeight
FontWeightThin = Text
"100"
  fontWeightAttr FontWeight
FontWeightUltraLight = Text
"200"
  fontWeightAttr FontWeight
FontWeightLight = Text
"300"
  fontWeightAttr FontWeight
FontWeightMedium = Text
"400"
  fontWeightAttr FontWeight
FontWeightSemiBold = Text
"600"
  fontWeightAttr FontWeight
FontWeightUltraBold = Text
"800"
  fontWeightAttr FontWeight
FontWeightHeavy = Text
"900"


renderFontFamily :: Style v n -> [Attribute]
renderFontFamily :: Style v n -> [Attribute]
renderFontFamily Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_family_ Maybe Text
ff
 where
  ff :: Maybe Text
ff = (String -> Text
pack (String -> Text) -> (Font -> String) -> Font -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> String
getFont) (Font -> Text) -> Maybe Font -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe Font
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s

-- | Render a style attribute if available, empty otherwise.
renderAttr :: Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr :: AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
attr Maybe s
valM = [Attribute] -> (s -> [Attribute]) -> Maybe s -> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\s
v -> [(AttrTag -> Text -> Attribute
bindAttr AttrTag
attr) (String -> Text
pack (String -> Text) -> (s -> String) -> s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Show a => a -> String
show (s -> Text) -> s -> Text
forall a b. (a -> b) -> a -> b
$ s
v)]) Maybe s
valM

-- renderTextAttr :: (AttributeValue -> Attribute) -> Maybe AttributeValue -> [Attribute]
renderTextAttr :: AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr :: AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
attr Maybe Text
valM = [Attribute] -> (Text -> [Attribute]) -> Maybe Text -> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
v -> [(AttrTag -> Text -> Attribute
bindAttr AttrTag
attr) Text
v]) Maybe Text
valM

colorToRgbText :: forall c . Color c => c -> AttributeValue
colorToRgbText :: c -> Text
colorToRgbText c
c = [Text] -> Text
T.concat
  [ Text
"rgb("
  , Double -> Text
forall a. RealFrac a => a -> Text
int Double
r, Text
","
  , Double -> Text
forall a. RealFrac a => a -> Text
int Double
g, Text
","
  , Double -> Text
forall a. RealFrac a => a -> Text
int Double
b
  , Text
")" ]
 where
   int :: a -> Text
int a
d     = String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ (a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (a
d a -> a -> a
forall a. Num a => a -> a -> a
* a
255) :: Int)
   (Double
r,Double
g,Double
b,Double
_) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c

colorToOpacity :: forall c . Color c => c -> Double
colorToOpacity :: c -> Double
colorToOpacity c
c = Double
a
 where (Double
_,Double
_,Double
_,Double
a) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c