{-# 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 svg-builder
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 :: forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(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 :: forall n.
SVGFloat n =>
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 -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
w
     , AttrTag
Height_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
h
     , AttrTag
Font_size_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"1"
     , AttrTag
ViewBox_ AttrTag -> AttributeValue -> Attribute
<<- ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> ([[Char]] -> [Char]) -> [[Char]] -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unwords ([[Char]] -> AttributeValue) -> [[Char]] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ (n -> [Char]) -> [n] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map n -> [Char]
forall a. Show a => a -> [Char]
show [n
0, n
0, n
w, n
h])
     , AttrTag
Stroke_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"rgb(0,0,0)"
     , AttrTag
Stroke_opacity_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"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 :: forall n. SVGFloat n => Path V2 n -> Element
renderPath Path V2 n
trs = if AttributeValue
makePath AttributeValue -> AttributeValue -> Bool
forall a. Eq a => a -> a -> Bool
== AttributeValue
T.empty then Element
forall a. Monoid a => a
mempty else [Attribute] -> Element
forall result. Term result => [Attribute] -> result
path_ [AttrTag
D_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
makePath]
  where
    makePath :: AttributeValue
makePath = (Located (Trail V2 n) -> AttributeValue)
-> [Located (Trail V2 n)] -> AttributeValue
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Located (Trail V2 n) -> AttributeValue
forall n. SVGFloat n => Located (Trail V2 n) -> AttributeValue
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 [Located (Trail V2 n)] -> Path V2 n
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 :: forall n. SVGFloat n => Located (Trail V2 n) -> AttributeValue
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 n
x n
y), Trail V2 n
t)) =
  n -> n -> AttributeValue
forall a. RealFloat a => a -> a -> AttributeValue
mA n
x n
y AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> (Trail' Line V2 n -> AttributeValue)
-> (Trail' Loop V2 n -> AttributeValue)
-> Trail V2 n
-> AttributeValue
forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line V2 n -> AttributeValue
renderLine Trail' Loop V2 n -> AttributeValue
forall {n}.
(Show n, Typeable n, RealFloat n) =>
Trail' Loop V2 n -> AttributeValue
renderLoop Trail V2 n
t
  where
    renderLine :: Trail' Line V2 n -> AttributeValue
renderLine = (Segment Closed V2 n -> AttributeValue)
-> [Segment Closed V2 n] -> AttributeValue
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> AttributeValue
forall n. SVGFloat n => Segment Closed V2 n -> AttributeValue
renderSeg ([Segment Closed V2 n] -> AttributeValue)
-> (Trail' Line V2 n -> [Segment Closed V2 n])
-> Trail' Line V2 n
-> AttributeValue
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 -> AttributeValue
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 -> AttributeValue)
-> [Segment Closed V2 n] -> AttributeValue
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> AttributeValue
forall n. SVGFloat n => Segment Closed V2 n -> AttributeValue
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 -> AttributeValue)
-> [Segment Closed V2 n] -> AttributeValue
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> AttributeValue
forall n. SVGFloat n => Segment Closed V2 n -> AttributeValue
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)
      AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
z

renderSeg :: SVGFloat n => Segment Closed V2 n -> AttributeValue
renderSeg :: forall n. SVGFloat n => Segment Closed V2 n -> AttributeValue
renderSeg (Linear (OffsetClosed (V2 n
x n
0))) = n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
hR n
x
renderSeg (Linear (OffsetClosed (V2 n
0 n
y))) = n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
vR n
y
renderSeg (Linear (OffsetClosed (V2 n
x n
y))) = n -> n -> AttributeValue
forall a. RealFloat a => a -> a -> AttributeValue
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 -> AttributeValue
forall a.
RealFloat a =>
a -> a -> a -> a -> a -> a -> AttributeValue
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 :: forall n.
SVGFloat n =>
Path V2 n -> AttributeValue -> Int -> Element -> Element
renderClip Path V2 n
p AttributeValue
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 -> AttributeValue -> Attribute
<<- (Int -> AttributeValue
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 -> AttributeValue -> Attribute
<<- (AttributeValue
"url(#" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> Int -> AttributeValue
clipPathId Int
ident AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
")")] Element
svg
    where
      clipPathId :: Int -> AttributeValue
clipPathId Int
i = AttributeValue
prefix AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"myClip" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Int
i)

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

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

renderLinearGradient :: SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient :: forall n. SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient LGradient n
g Int
i = [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
linearGradient_
    [ AttrTag
Id_ AttrTag -> AttributeValue -> Attribute
<<- ([Char] -> AttributeValue
pack ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
"gradient" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)
    , AttrTag
X1_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
x1
    , AttrTag
Y1_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
y1
    , AttrTag
X2_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
x2
    , AttrTag
Y2_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
y2
    , AttrTag
GradientTransform_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
mx
    , AttrTag
GradientUnits_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"userSpaceOnUse"
    , AttrTag
SpreadMethod_ AttrTag -> AttributeValue -> Attribute
<<- SpreadMethod -> AttributeValue
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 (f :: * -> *).
Functor f =>
(SpreadMethod -> f SpreadMethod) -> LGradient n -> f (LGradient n)
lGradSpreadMethod) ]
    (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ (GradientStop n -> Element) -> [GradientStop n] -> Element
forall m a. Monoid m => (a -> m) -> [a] -> m
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 (f :: * -> *).
Functor f =>
([GradientStop n] -> f [GradientStop n])
-> LGradient n -> f (LGradient n)
lGradStops)
  where
    mx :: AttributeValue
mx = n -> n -> n -> n -> n -> n -> AttributeValue
forall a.
RealFloat a =>
a -> a -> a -> a -> a -> a -> AttributeValue
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 (f :: * -> *).
Functor f =>
(Transformation V2 n -> f (Transformation V2 n))
-> LGradient n -> f (LGradient 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 (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> LGradient n -> f (LGradient 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 (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> LGradient n -> f (LGradient n)
lGradEnd

renderRadialGradient :: SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient :: forall n. SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient RGradient n
g Int
i = [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
radialGradient_
    [ AttrTag
Id_ AttrTag -> AttributeValue -> Attribute
<<- ([Char] -> AttributeValue
pack ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char]
"gradient" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)
    , AttrTag
R_  AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
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 (f :: * -> *).
Functor f =>
(n -> f n) -> RGradient n -> f (RGradient n)
rGradRadius1)
    , AttrTag
Cx_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
cx
    , AttrTag
Cy_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
cy
    , AttrTag
Fx_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
fx
    , AttrTag
Fy_ AttrTag -> AttributeValue -> Attribute
<<- n -> AttributeValue
forall a. RealFloat a => a -> AttributeValue
toText n
fy
    , AttrTag
GradientTransform_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
mx
    , AttrTag
GradientUnits_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"userSpaceOnUse"
    , AttrTag
SpreadMethod_ AttrTag -> AttributeValue -> Attribute
<<- SpreadMethod -> AttributeValue
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 (f :: * -> *).
Functor f =>
(SpreadMethod -> f SpreadMethod) -> RGradient n -> f (RGradient n)
rGradSpreadMethod) ]
    ( (GradientStop n -> Element) -> [GradientStop n] -> Element
forall m a. Monoid m => (a -> m) -> [a] -> m
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 :: AttributeValue
mx = n -> n -> n -> n -> n -> n -> AttributeValue
forall a.
RealFloat a =>
a -> a -> a -> a -> a -> a -> AttributeValue
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 (f :: * -> *).
Functor f =>
(Transformation V2 n -> f (Transformation V2 n))
-> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(n -> f n) -> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(n -> f n) -> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(n -> f n) -> GradientStop n -> f (GradientStop 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 (f :: * -> *).
Functor f =>
([GradientStop n] -> f [GradientStop n])
-> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
([GradientStop n] -> f [GradientStop n])
-> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(n -> f n) -> GradientStop n -> f (GradientStop 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 :: forall n (v :: * -> *). SVGFloat n => 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 :: forall n (v :: * -> *).
SVGFloat n =>
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 AttributeValue -> [Attribute]
renderTextAttr AttrTag
Fill_ Maybe AttributeValue
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 AttributeValue
fillColorRgb     = AttributeValue -> Maybe AttributeValue
forall a. a -> Maybe a
Just (AttributeValue -> Maybe AttributeValue)
-> AttributeValue -> Maybe AttributeValue
forall a b. (a -> b) -> a -> b
$ c -> AttributeValue
forall c. Color c => c -> AttributeValue
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 -> AttributeValue -> Attribute
<<- (AttributeValue
"url(#gradient" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                             AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
")"), AttrTag
Fill_opacity_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"1"]
  Just (RG RGradient n
_) -> [AttrTag
Fill_ AttrTag -> AttributeValue -> Attribute
<<- (AttributeValue
"url(#gradient" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                             AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
")"), AttrTag
Fill_opacity_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"1"]
  Maybe (Texture n)
Nothing     -> []

renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> Element
renderLineTextureDefs :: forall n (v :: * -> *). SVGFloat n => 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 :: forall n (v :: * -> *).
SVGFloat n =>
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 AttributeValue -> [Attribute]
renderTextAttr AttrTag
Stroke_ Maybe AttributeValue
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 AttributeValue
lineColorRgb     = AttributeValue -> Maybe AttributeValue
forall a. a -> Maybe a
Just (AttributeValue -> Maybe AttributeValue)
-> AttributeValue -> Maybe AttributeValue
forall a b. (a -> b) -> a -> b
$ c -> AttributeValue
forall c. Color c => c -> AttributeValue
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 -> AttributeValue -> Attribute
<<- (AttributeValue
"url(#gradient" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                               AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
")"), AttrTag
Stroke_opacity_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"1"]
  Just (RG RGradient n
_) -> [AttrTag
Stroke_ AttrTag -> AttributeValue -> Attribute
<<- (AttributeValue
"url(#gradient" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Int
ident)
                                               AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
")"), AttrTag
Stroke_opacity_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"1"]
  Maybe (Texture n)
Nothing     -> []

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

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

renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> Element
renderDImage :: forall n any.
SVGFloat n =>
DImage n any -> AttributeValue -> Element
renderDImage (DImage ImageData any
_ Int
w Int
h Transformation V2 n
tr) AttributeValue
uridata =
  [Attribute] -> Element
forall result. Term result => [Attribute] -> result
image_
    [ AttrTag
Transform_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
transformMatrix
    , AttrTag
Width_ AttrTag -> AttributeValue -> Attribute
<<-  ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Int
w)
    , AttrTag
Height_ AttrTag -> AttributeValue -> Attribute
<<- ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Int
h)
    , AttrTag
XlinkHref_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
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 :: AttributeValue
transformMatrix = n -> n -> n -> n -> n -> n -> AttributeValue
forall a.
RealFloat a =>
a -> a -> a -> a -> a -> a -> AttributeValue
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 :: forall n. SVGFloat n => Text n -> Element
renderText (Text T2 n
tt TextAlignment n
tAlign [Char]
str) =
  [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
text_
    [ AttrTag
Transform_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
transformMatrix
    , AttrTag
Dominant_baseline_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
vAlign
    , AttrTag
Text_anchor_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
hAlign
    , AttrTag
Stroke_ AttrTag -> AttributeValue -> Attribute
<<- AttributeValue
"none" ]
    (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ [Char] -> Element
forall a. ToElement a => a -> Element
toElement [Char]
str
 where
  vAlign :: AttributeValue
vAlign = case TextAlignment n
tAlign of
             TextAlignment n
BaselineText -> AttributeValue
"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 -> AttributeValue
"text-after-edge"
               n
h' | n
h' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0.75 -> AttributeValue
"text-before-edge"
               n
_ -> AttributeValue
"middle"
  hAlign :: AttributeValue
hAlign = case TextAlignment n
tAlign of
             TextAlignment n
BaselineText -> AttributeValue
"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 -> AttributeValue
"start"
               n
w' | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0.75 -> AttributeValue
"end"
               n
_ -> AttributeValue
"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 :: AttributeValue
transformMatrix     = n -> n -> n -> n -> n -> n -> AttributeValue
forall a.
RealFloat a =>
a -> a -> a -> a -> a -> a -> AttributeValue
matrix n
a n
b n
c n
d n
e n
f

renderStyles :: SVGFloat n => Int -> Int -> Style v n -> [Attribute]
renderStyles :: forall n (v :: * -> *).
SVGFloat n =>
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 :: forall (v :: * -> *) n. 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 :: forall (v :: * -> *) n. 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 :: forall (v :: * -> *) n. Style v n -> [Attribute]
renderFillRule Style v n
s = AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr AttrTag
Fill_rule_ Maybe AttributeValue
fr
  where fr :: Maybe AttributeValue
fr = (FillRule -> AttributeValue
fillRuleToText (FillRule -> AttributeValue)
-> (FillRule -> FillRule) -> FillRule -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> FillRule
getFillRule) (FillRule -> AttributeValue)
-> Maybe FillRule -> Maybe AttributeValue
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 -> AttributeValue
fillRuleToText FillRule
Winding = AttributeValue
"nonzero"
        fillRuleToText FillRule
EvenOdd = AttributeValue
"evenodd"

renderLineWidth :: SVGFloat n => Style v n -> [Attribute]
renderLineWidth :: forall n (v :: * -> *). SVGFloat n => 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 :: forall (v :: * -> *) n. Style v n -> [Attribute]
renderLineCap Style v n
s = AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr AttrTag
Stroke_linecap_ Maybe AttributeValue
lCap
  where lCap :: Maybe AttributeValue
lCap = (LineCap -> AttributeValue
lineCapToText (LineCap -> AttributeValue)
-> (LineCap -> LineCap) -> LineCap -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap) (LineCap -> AttributeValue)
-> Maybe LineCap -> Maybe AttributeValue
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 -> AttributeValue
lineCapToText LineCap
LineCapButt   = AttributeValue
"butt"
        lineCapToText LineCap
LineCapRound  = AttributeValue
"round"
        lineCapToText LineCap
LineCapSquare = AttributeValue
"square"

renderLineJoin :: Style v n -> [Attribute]
renderLineJoin :: forall (v :: * -> *) n. Style v n -> [Attribute]
renderLineJoin Style v n
s = AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr AttrTag
Stroke_linejoin_ Maybe AttributeValue
lj
  where lj :: Maybe AttributeValue
lj = (LineJoin -> AttributeValue
lineJoinToText (LineJoin -> AttributeValue)
-> (LineJoin -> LineJoin) -> LineJoin -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin) (LineJoin -> AttributeValue)
-> Maybe LineJoin -> Maybe AttributeValue
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 -> AttributeValue
lineJoinToText LineJoin
LineJoinMiter = AttributeValue
"miter"
        lineJoinToText LineJoin
LineJoinRound = AttributeValue
"round"
        lineJoinToText LineJoin
LineJoinBevel = AttributeValue
"bevel"

renderDashing :: SVGFloat n => Style v n -> [Attribute]
renderDashing :: forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderDashing Style v n
s = AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr AttrTag
Stroke_dasharray_ Maybe AttributeValue
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] -> [Char]
dashArrayToStr = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ([[Char]] -> [Char]) -> ([n] -> [[Char]]) -> [n] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> [Char]) -> [n] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map n -> [Char]
forall a. Show a => a -> [Char]
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 AttributeValue
arr = ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Dashing n -> [Char]) -> Dashing n -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [n] -> [Char]
dashArrayToStr ([n] -> [Char]) -> (Dashing n -> [n]) -> Dashing n -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dashing n -> [n]
forall {n}. Dashing n -> [n]
getDasharray) (Dashing n -> AttributeValue)
-> Maybe (Dashing n) -> Maybe AttributeValue
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 :: forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderFontSize Style v n
s = AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr AttrTag
Font_size_ Maybe AttributeValue
fs
 where
  fs :: Maybe AttributeValue
fs = [Char] -> AttributeValue
pack ([Char] -> AttributeValue) -> Maybe [Char] -> Maybe AttributeValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FontSize n -> [Char]) -> Style v n -> Maybe [Char]
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr (([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"px") ([Char] -> [Char])
-> (FontSize n -> [Char]) -> FontSize n -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> [Char]
forall a. Show a => a -> [Char]
show (n -> [Char]) -> (FontSize n -> n) -> FontSize n -> [Char]
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 :: forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontSlant Style v n
s = AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr AttrTag
Font_style_ Maybe AttributeValue
fs
 where
  fs :: Maybe AttributeValue
fs = (FontSlant -> AttributeValue
fontSlantAttr (FontSlant -> AttributeValue)
-> (FontSlant -> FontSlant) -> FontSlant -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSlant -> FontSlant
getFontSlant) (FontSlant -> AttributeValue)
-> Maybe FontSlant -> Maybe AttributeValue
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 -> AttributeValue
fontSlantAttr FontSlant
FontSlantItalic  = AttributeValue
"italic"
  fontSlantAttr FontSlant
FontSlantOblique = AttributeValue
"oblique"
  fontSlantAttr FontSlant
FontSlantNormal  = AttributeValue
"normal"

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


renderFontFamily :: Style v n -> [Attribute]
renderFontFamily :: forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontFamily Style v n
s = AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr AttrTag
Font_family_ Maybe AttributeValue
ff
 where
  ff :: Maybe AttributeValue
ff = ([Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Font -> [Char]) -> Font -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> [Char]
getFont) (Font -> AttributeValue) -> Maybe Font -> Maybe AttributeValue
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 :: forall s. Show s => 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 -> AttributeValue -> Attribute
bindAttr AttrTag
attr) ([Char] -> AttributeValue
pack ([Char] -> AttributeValue) -> (s -> [Char]) -> s -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> [Char]
forall a. Show a => a -> [Char]
show (s -> AttributeValue) -> s -> AttributeValue
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 AttributeValue -> [Attribute]
renderTextAttr AttrTag
attr Maybe AttributeValue
valM = [Attribute]
-> (AttributeValue -> [Attribute])
-> Maybe AttributeValue
-> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\AttributeValue
v -> [(AttrTag -> AttributeValue -> Attribute
bindAttr AttrTag
attr) AttributeValue
v]) Maybe AttributeValue
valM

colorToRgbText :: forall c . Color c => c -> AttributeValue
colorToRgbText :: forall c. Color c => c -> AttributeValue
colorToRgbText c
c = [AttributeValue] -> AttributeValue
T.concat
  [ AttributeValue
"rgb("
  , Double -> AttributeValue
forall {a}. RealFrac a => a -> AttributeValue
int Double
r, AttributeValue
","
  , Double -> AttributeValue
forall {a}. RealFrac a => a -> AttributeValue
int Double
g, AttributeValue
","
  , Double -> AttributeValue
forall {a}. RealFrac a => a -> AttributeValue
int Double
b
  , AttributeValue
")" ]
 where
   int :: a -> AttributeValue
int a
d     = [Char] -> AttributeValue
pack ([Char] -> AttributeValue)
-> (Int -> [Char]) -> Int -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> AttributeValue) -> Int -> AttributeValue
forall a b. (a -> b) -> a -> b
$ (a -> Int
forall b. Integral b => a -> b
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 :: forall c. Color c => 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