{-# 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 f :: 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 w :: n
w h :: n
h defines :: Maybe Element
defines attributes :: [Attribute]
attributes genDoctype :: Bool
genDoctype s :: 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
<<- "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 [0, 0, n
w, n
h])
     , AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- "rgb(0,0,0)"
     , AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- "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 trs :: 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), t :: 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 lp :: 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
        (segs :: [Segment Closed V2 n]
segs, Linear _) -> (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 -> 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 x :: n
x 0))) = n -> Text
forall a. RealFloat a => a -> Text
hR n
x
renderSeg (Linear (OffsetClosed (V2 0 y :: n
y))) = n -> Text
forall a. RealFloat a => a -> Text
vR n
y
renderSeg (Linear (OffsetClosed (V2 x :: n
x y :: n
y))) = n -> n -> Text
forall a. RealFloat a => a -> a -> Text
lR n
x n
y
renderSeg (Cubic  (V2 x0 :: n
x0 y0 :: n
y0)
                  (V2 x1 :: n
x1 y1 :: n
y1)
                  (OffsetClosed (V2 x2 :: n
x2 y2 :: 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 p :: Path V2 n
p prefix :: Text
prefix ident :: Int
ident svg :: 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
<<- ("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
<> ")")] Element
svg
    where
      clipPathId :: Int -> Text
clipPathId i :: Int
i = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "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 c :: SomeColor
c v :: 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 GradPad      = "pad"
spreadMethodText GradReflect  = "reflect"
spreadMethodText GradRepeat   = "repeat"

renderLinearGradient :: SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient :: LGradient n -> Int -> Element
renderLinearGradient g :: LGradient n
g i :: 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
$ "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
<<- "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
    [[a1 :: n
a1, a2 :: n
a2], [b1 :: n
b1, b2 :: n
b2], [c1 :: n
c1, c2 :: 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 x1 :: n
x1 y1 :: 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 x2 :: n
x2 y2 :: 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 g :: RGradient n
g i :: 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
$ "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
<<- "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
    [[a1 :: n
a1, a2 :: n
a2], [b1 :: n
b1, b2 :: n
b2], [c1 :: n
c1, c2 :: 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 cx :: n
cx cy :: 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 fx :: n
fx fy :: 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 (\s :: 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@(x :: GradientStop n
x:_) -> 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 (\gs :: GradientStop n
gs sf :: 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 i :: Int
i s :: 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 g :: 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 g :: 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
    _           -> 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 ident :: Int
ident s :: 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
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 _) -> [AttrTag
Fill_ AttrTag -> Text -> Attribute
<<- ("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
<> ")"), AttrTag
Fill_opacity_ AttrTag -> Text -> Attribute
<<- "1"]
  Just (RG _) -> [AttrTag
Fill_ AttrTag -> Text -> Attribute
<<- ("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
<> ")"), AttrTag
Fill_opacity_ AttrTag -> Text -> Attribute
<<- "1"]
  Nothing     -> []

renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> Element
renderLineTextureDefs :: Int -> Style v n -> Element
renderLineTextureDefs i :: Int
i s :: 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 g :: 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 g :: 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
    _           -> Element
forall a. Monoid a => a
mempty

renderLineTexture :: SVGFloat n => Int -> Style v n -> [Attribute]
renderLineTexture :: Int -> Style v n -> [Attribute]
renderLineTexture ident :: Int
ident s :: 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
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 _) -> [AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- ("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
<> ")"), AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- "1"]
  Just (RG _) -> [AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- ("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
<> ")"), AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- "1"]
  Nothing     -> []

dataUri :: String -> BS8.ByteString -> AttributeValue
dataUri :: String -> ByteString -> Text
dataUri mime :: String
mime dat :: ByteString
dat = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ "data:"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mimeString -> String -> String
forall a. [a] -> [a] -> [a]
++";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 dImg :: DynamicImage
dImg) _ _ _) =
  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 "image/png" ByteString
img
  where
    img :: ByteString
img = case DynamicImage -> Either String ByteString
encodeDynamicPng DynamicImage
dImg of
            Left str :: String
str   -> String -> ByteString
forall a. HasCallStack => String -> a
error String
str
            Right img' :: ByteString
img' -> ByteString
img'

renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> Element
renderDImage :: DImage n any -> Text -> Element
renderDImage (DImage _ w :: Int
w h :: Int
h tr :: Transformation V2 n
tr) uridata :: 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
    [[a :: n
a,b :: n
b],[c :: n
c,d :: n
d],[e :: n
e,f :: 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
/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
/2

renderText :: SVGFloat n => Text n -> Element
renderText :: Text n -> Element
renderText (Text tt :: T2 n
tt tAlign :: TextAlignment n
tAlign str :: 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
<<- "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
             BaselineText -> "alphabetic"
             BoxAlignedText _ h :: n
h -> case n
h of -- A mere approximation
               h' :: n
h' | n
h' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= 0.25 -> "text-after-edge"
               h' :: n
h' | n
h' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= 0.75 -> "text-before-edge"
               _ -> "middle"
  hAlign :: Text
hAlign = case TextAlignment n
tAlign of
             BaselineText -> "start"
             BoxAlignedText w :: n
w _ -> case n
w of -- A mere approximation
               w' :: n
w' | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= 0.25 -> "start"
               w' :: n
w' | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= 0.75 -> "end"
               _ -> "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
  [[a :: n
a,b :: n
b],[c :: n
c,d :: n
d],[e :: n
e,f :: 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 fillId :: Int
fillId lineId :: Int
lineId s :: 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 s :: 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 s :: 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 s :: 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 Winding = "nonzero"
        fillRuleToText EvenOdd = "evenodd"

renderLineWidth :: SVGFloat n => Style v n -> [Attribute]
renderLineWidth :: Style v n -> [Attribute]
renderLineWidth s :: 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 s :: 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 LineCapButt   = "butt"
        lineCapToText LineCapRound  = "round"
        lineCapToText LineCapSquare = "square"

renderLineJoin :: Style v n -> [Attribute]
renderLineJoin :: Style v n -> [Attribute]
renderLineJoin s :: 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 LineJoinMiter = "miter"
        lineJoinToText LineJoinRound = "round"
        lineJoinToText LineJoinBevel = "bevel"

renderDashing :: SVGFloat n => Style v n -> [Attribute]
renderDashing :: Style v n -> [Attribute]
renderDashing s :: 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 a :: [n]
a _) = [n]
a
  getDashoffset :: Dashing n -> n
getDashoffset (Dashing _ o :: n
o) = n
o
  dashArrayToStr :: [n] -> String
dashArrayToStr = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," ([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 [] _)) = Maybe (Dashing n)
forall a. Maybe a
Nothing
  checkEmpty other :: 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 s :: 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]
++ "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 s :: 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 FontSlantItalic  = "italic"
  fontSlantAttr FontSlantOblique = "oblique"
  fontSlantAttr FontSlantNormal  = "normal"

renderFontWeight :: Style v n -> [Attribute]
renderFontWeight :: Style v n -> [Attribute]
renderFontWeight s :: 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 FontWeightNormal = "normal"
  fontWeightAttr FontWeightBold   = "bold"
  fontWeightAttr FontWeightLighter = "lighter"
  fontWeightAttr FontWeightBolder  = "bolder"
  fontWeightAttr FontWeightThin = "100"
  fontWeightAttr FontWeightUltraLight = "200"
  fontWeightAttr FontWeightLight = "300"
  fontWeightAttr FontWeightMedium = "400"
  fontWeightAttr FontWeightSemiBold = "600"
  fontWeightAttr FontWeightUltraBold = "800"
  fontWeightAttr FontWeightHeavy = "900"


renderFontFamily :: Style v n -> [Attribute]
renderFontFamily :: Style v n -> [Attribute]
renderFontFamily s :: 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 attr :: AttrTag
attr valM :: Maybe s
valM = [Attribute] -> (s -> [Attribute]) -> Maybe s -> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\v :: 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 attr :: AttrTag
attr valM :: Maybe Text
valM = [Attribute] -> (Text -> [Attribute]) -> Maybe Text -> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\v :: 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
c = [Text] -> Text
T.concat
  [ "rgb("
  , Double -> Text
forall a. RealFrac a => a -> Text
int Double
r, ","
  , Double -> Text
forall a. RealFrac a => a -> Text
int Double
g, ","
  , Double -> Text
forall a. RealFrac a => a -> Text
int Double
b
  , ")" ]
 where
   int :: a -> Text
int d :: 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
* 255) :: Int)
   (r :: Double
r,g :: Double
g,b :: Double
b,_) = 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
c = Double
a
 where (_,_,_,a :: Double
a) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c