{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Graphics.Rendering.SVG
( SVGFloat
, Element
, AttributeValue
, svgHeader
, renderPath
, renderClip
, renderText
, renderDImage
, renderDImageEmb
, renderStyles
, renderMiterLimit
, renderFillTextureDefs
, renderFillTexture
, renderLineTextureDefs
, renderLineTexture
, dataUri
, getNumAttr
) where
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
import Diagrams.Core.Transform (matrixHomRep)
import Diagrams.Prelude hiding (Attribute, Render, with, (<>))
import Diagrams.TwoD.Path (getFillRule)
import Diagrams.TwoD.Text
import Data.Text (pack)
import qualified Data.Text as T
import Graphics.Svg hiding (renderText)
import qualified Data.ByteString.Base64.Lazy as BS64
import qualified Data.ByteString.Lazy.Char8 as BS8
import Codec.Picture
type SVGFloat n = (Show n, TypeableFloat n)
type AttributeValue = T.Text
getNumAttr :: AttributeClass (a n) => (a n -> t) -> Style v n -> Maybe t
getNumAttr :: (a n -> t) -> Style v n -> Maybe t
getNumAttr a n -> t
f = (a n -> t
f (a n -> t) -> Maybe (a n) -> Maybe t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe (a n) -> Maybe t)
-> (Style v n -> Maybe (a n)) -> Style v n -> Maybe t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style v n -> Maybe (a n)
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr
svgHeader :: SVGFloat n => n -> n -> Maybe Element -> [Attribute] -> Bool
-> Element -> Element
n
w n
h Maybe Element
defines [Attribute]
attributes Bool
genDoctype Element
s =
Element
dt Element -> Element -> Element
forall a. Semigroup a => a -> a -> a
<> Element -> [Attribute] -> Element
with (Element -> Element
svg11_ ([Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] Element
ds Element -> Element -> Element
forall a. Semigroup a => a -> a -> a
<> Element
s))
([ AttrTag
Width_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
w
, AttrTag
Height_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
h
, AttrTag
Font_size_ AttrTag -> Text -> Attribute
<<- Text
"1"
, AttrTag
ViewBox_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ (n -> String) -> [n] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map n -> String
forall a. Show a => a -> String
show [n
0, n
0, n
w, n
h])
, AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- Text
"rgb(0,0,0)"
, AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1" ]
[Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Attribute]
attributes )
where
ds :: Element
ds = Element -> Maybe Element -> Element
forall a. a -> Maybe a -> a
fromMaybe Element
forall a. Monoid a => a
mempty Maybe Element
defines
dt :: Element
dt = if Bool
genDoctype then Element
doctype else Element
forall a. Monoid a => a
mempty
renderPath :: SVGFloat n => Path V2 n -> Element
renderPath :: Path V2 n -> Element
renderPath Path V2 n
trs = if Text
makePath Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty then Element
forall a. Monoid a => a
mempty else [Attribute] -> Element
forall result. Term result => [Attribute] -> result
path_ [AttrTag
D_ AttrTag -> Text -> Attribute
<<- Text
makePath]
where
makePath :: Text
makePath = (Located (Trail V2 n) -> Text) -> [Located (Trail V2 n)] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Located (Trail V2 n) -> Text
forall n. SVGFloat n => Located (Trail V2 n) -> Text
renderTrail ((Unwrapped (Path V2 n) -> Path V2 n)
-> Path V2 n -> Unwrapped (Path V2 n)
forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op Unwrapped (Path V2 n) -> Path V2 n
forall (v :: * -> *) n. [Located (Trail v n)] -> Path v n
Path Path V2 n
trs)
renderTrail :: SVGFloat n => Located (Trail V2 n) -> AttributeValue
renderTrail :: Located (Trail V2 n) -> Text
renderTrail (Located (Trail V2 n)
-> (Point (V (Trail V2 n)) (N (Trail V2 n)), Trail V2 n)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (P (V2 x y), Trail V2 n
t)) =
n -> n -> Text
forall a. RealFloat a => a -> a -> Text
mA n
x n
y Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Trail' Line V2 n -> Text)
-> (Trail' Loop V2 n -> Text) -> Trail V2 n -> Text
forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line V2 n -> Text
renderLine Trail' Loop V2 n -> Text
forall n.
(Show n, Typeable n, RealFloat n) =>
Trail' Loop V2 n -> Text
renderLoop Trail V2 n
t
where
renderLine :: Trail' Line V2 n -> Text
renderLine = (Segment Closed V2 n -> Text) -> [Segment Closed V2 n] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> Text
forall n. SVGFloat n => Segment Closed V2 n -> Text
renderSeg ([Segment Closed V2 n] -> Text)
-> (Trail' Line V2 n -> [Segment Closed V2 n])
-> Trail' Line V2 n
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Line V2 n -> [Segment Closed V2 n]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments
renderLoop :: Trail' Loop V2 n -> Text
renderLoop Trail' Loop V2 n
lp =
case Trail' Loop V2 n -> ([Segment Closed V2 n], Segment Open V2 n)
forall (v :: * -> *) n.
Trail' Loop v n -> ([Segment Closed v n], Segment Open v n)
loopSegments Trail' Loop V2 n
lp of
([Segment Closed V2 n]
segs, Linear Offset Open V2 n
_) -> (Segment Closed V2 n -> Text) -> [Segment Closed V2 n] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> Text
forall n. SVGFloat n => Segment Closed V2 n -> Text
renderSeg [Segment Closed V2 n]
segs
([Segment Closed V2 n], Segment Open V2 n)
_ -> (Segment Closed V2 n -> Text) -> [Segment Closed V2 n] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Segment Closed V2 n -> Text
forall n. SVGFloat n => Segment Closed V2 n -> Text
renderSeg (Trail' Line V2 n -> [Segment Closed V2 n]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments (Trail' Line V2 n -> [Segment Closed V2 n])
-> (Trail' Loop V2 n -> Trail' Line V2 n)
-> Trail' Loop V2 n
-> [Segment Closed V2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Loop V2 n -> Trail' Line V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop (Trail' Loop V2 n -> [Segment Closed V2 n])
-> Trail' Loop V2 n -> [Segment Closed V2 n]
forall a b. (a -> b) -> a -> b
$ Trail' Loop V2 n
lp)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
z
renderSeg :: SVGFloat n => Segment Closed V2 n -> AttributeValue
renderSeg :: Segment Closed V2 n -> Text
renderSeg (Linear (OffsetClosed (V2 n
x n
0))) = n -> Text
forall a. RealFloat a => a -> Text
hR n
x
renderSeg (Linear (OffsetClosed (V2 n
0 n
y))) = n -> Text
forall a. RealFloat a => a -> Text
vR n
y
renderSeg (Linear (OffsetClosed (V2 n
x n
y))) = n -> n -> Text
forall a. RealFloat a => a -> a -> Text
lR n
x n
y
renderSeg (Cubic (V2 n
x0 n
y0)
(V2 n
x1 n
y1)
(OffsetClosed (V2 n
x2 n
y2))) = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
cR n
x0 n
y0 n
x1 n
y1 n
x2 n
y2
renderClip :: SVGFloat n => Path V2 n -> T.Text -> Int -> Element -> Element
renderClip :: Path V2 n -> Text -> Int -> Element -> Element
renderClip Path V2 n
p Text
prefix Int
ident Element
svg = do
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
clipPath_ [AttrTag
Id_ AttrTag -> Text -> Attribute
<<- (Int -> Text
clipPathId Int
ident)] (Path V2 n -> Element
forall n. SVGFloat n => Path V2 n -> Element
renderPath Path V2 n
p)
Element -> Element -> Element
forall a. Semigroup a => a -> a -> a
<> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ [AttrTag
Clip_path_ AttrTag -> Text -> Attribute
<<- (Text
"url(#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
clipPathId Int
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")] Element
svg
where
clipPathId :: Int -> Text
clipPathId Int
i = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"myClip" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
i)
renderStop :: SVGFloat n => GradientStop n -> Element
renderStop :: GradientStop n -> Element
renderStop (GradientStop SomeColor
c n
v)
= [Attribute] -> Element
forall result. Term result => [Attribute] -> result
stop_ [ AttrTag
Stop_color_ AttrTag -> Text -> Attribute
<<- (SomeColor -> Text
forall c. Color c => c -> Text
colorToRgbText SomeColor
c)
, AttrTag
Offset_ AttrTag -> Text -> Attribute
<<- (n -> Text
forall a. RealFloat a => a -> Text
toText n
v)
, AttrTag
Stop_opacity_ AttrTag -> Text -> Attribute
<<- (Double -> Text
forall a. RealFloat a => a -> Text
toText (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ SomeColor -> Double
forall c. Color c => c -> Double
colorToOpacity SomeColor
c) ]
spreadMethodText :: SpreadMethod -> AttributeValue
spreadMethodText :: SpreadMethod -> Text
spreadMethodText SpreadMethod
GradPad = Text
"pad"
spreadMethodText SpreadMethod
GradReflect = Text
"reflect"
spreadMethodText SpreadMethod
GradRepeat = Text
"repeat"
renderLinearGradient :: SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient :: LGradient n -> Int -> Element
renderLinearGradient LGradient n
g Int
i = [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
linearGradient_
[ AttrTag
Id_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"gradient" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
, AttrTag
X1_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
x1
, AttrTag
Y1_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
y1
, AttrTag
X2_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
x2
, AttrTag
Y2_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
y2
, AttrTag
GradientTransform_ AttrTag -> Text -> Attribute
<<- Text
mx
, AttrTag
GradientUnits_ AttrTag -> Text -> Attribute
<<- Text
"userSpaceOnUse"
, AttrTag
SpreadMethod_ AttrTag -> Text -> Attribute
<<- SpreadMethod -> Text
spreadMethodText (LGradient n
g LGradient n
-> Getting SpreadMethod (LGradient n) SpreadMethod -> SpreadMethod
forall s a. s -> Getting a s a -> a
^. Getting SpreadMethod (LGradient n) SpreadMethod
forall n. Lens' (LGradient n) SpreadMethod
lGradSpreadMethod) ]
(Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ (GradientStop n -> Element) -> [GradientStop n] -> Element
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GradientStop n -> Element
forall n. SVGFloat n => GradientStop n -> Element
renderStop (LGradient n
gLGradient n
-> Getting [GradientStop n] (LGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^.Getting [GradientStop n] (LGradient n) [GradientStop n]
forall n. Lens' (LGradient n) [GradientStop n]
lGradStops)
where
mx :: Text
mx = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a1 n
a2 n
b1 n
b2 n
c1 n
c2
[[n
a1, n
a2], [n
b1, n
b2], [n
c1, n
c2]] = Transformation V2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (LGradient n
g LGradient n
-> Getting
(Transformation V2 n) (LGradient n) (Transformation V2 n)
-> Transformation V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Transformation V2 n) (LGradient n) (Transformation V2 n)
forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans)
P (V2 n
x1 n
y1) = LGradient n
g LGradient n
-> Getting (Point V2 n) (LGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (LGradient n) (Point V2 n)
forall n. Lens' (LGradient n) (Point V2 n)
lGradStart
P (V2 n
x2 n
y2) = LGradient n
g LGradient n
-> Getting (Point V2 n) (LGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (LGradient n) (Point V2 n)
forall n. Lens' (LGradient n) (Point V2 n)
lGradEnd
renderRadialGradient :: SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient :: RGradient n -> Int -> Element
renderRadialGradient RGradient n
g Int
i = [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
radialGradient_
[ AttrTag
Id_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"gradient" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
, AttrTag
R_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText (RGradient n
g RGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius1)
, AttrTag
Cx_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
cx
, AttrTag
Cy_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
cy
, AttrTag
Fx_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
fx
, AttrTag
Fy_ AttrTag -> Text -> Attribute
<<- n -> Text
forall a. RealFloat a => a -> Text
toText n
fy
, AttrTag
GradientTransform_ AttrTag -> Text -> Attribute
<<- Text
mx
, AttrTag
GradientUnits_ AttrTag -> Text -> Attribute
<<- Text
"userSpaceOnUse"
, AttrTag
SpreadMethod_ AttrTag -> Text -> Attribute
<<- SpreadMethod -> Text
spreadMethodText (RGradient n
g RGradient n
-> Getting SpreadMethod (RGradient n) SpreadMethod -> SpreadMethod
forall s a. s -> Getting a s a -> a
^. Getting SpreadMethod (RGradient n) SpreadMethod
forall n. Lens' (RGradient n) SpreadMethod
rGradSpreadMethod) ]
( (GradientStop n -> Element) -> [GradientStop n] -> Element
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GradientStop n -> Element
forall n. SVGFloat n => GradientStop n -> Element
renderStop [GradientStop n]
ss )
where
mx :: Text
mx = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a1 n
a2 n
b1 n
b2 n
c1 n
c2
[[n
a1, n
a2], [n
b1, n
b2], [n
c1, n
c2]] = Transformation V2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (RGradient n
g RGradient n
-> Getting
(Transformation V2 n) (RGradient n) (Transformation V2 n)
-> Transformation V2 n
forall s a. s -> Getting a s a -> a
^.Getting (Transformation V2 n) (RGradient n) (Transformation V2 n)
forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans)
P (V2 n
cx n
cy) = RGradient n
g RGradient n
-> Getting (Point V2 n) (RGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (RGradient n) (Point V2 n)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter1
P (V2 n
fx n
fy) = RGradient n
g RGradient n
-> Getting (Point V2 n) (RGradient n) (Point V2 n) -> Point V2 n
forall s a. s -> Getting a s a -> a
^. Getting (Point V2 n) (RGradient n) (Point V2 n)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter0
r0 :: n
r0 = RGradient n
g RGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius0
r1 :: n
r1 = RGradient n
g RGradient n -> Getting n (RGradient n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (RGradient n) n
forall n. Lens' (RGradient n) n
rGradRadius1
stopFracs :: [n]
stopFracs = n
r0 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
r1 n -> [n] -> [n]
forall a. a -> [a] -> [a]
: (GradientStop n -> n) -> [GradientStop n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (\GradientStop n
s -> (n
r0 n -> n -> n
forall a. Num a => a -> a -> a
+ (GradientStop n
s GradientStop n -> Getting n (GradientStop n) n -> n
forall s a. s -> Getting a s a -> a
^. Getting n (GradientStop n) n
forall n. Lens' (GradientStop n) n
stopFraction) n -> n -> n
forall a. Num a => a -> a -> a
* (n
r1 n -> n -> n
forall a. Num a => a -> a -> a
- n
r0)) n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
r1)
(RGradient n
g RGradient n
-> Getting [GradientStop n] (RGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^. Getting [GradientStop n] (RGradient n) [GradientStop n]
forall n. Lens' (RGradient n) [GradientStop n]
rGradStops)
gradStops :: [GradientStop n]
gradStops = case RGradient n
g RGradient n
-> Getting [GradientStop n] (RGradient n) [GradientStop n]
-> [GradientStop n]
forall s a. s -> Getting a s a -> a
^. Getting [GradientStop n] (RGradient n) [GradientStop n]
forall n. Lens' (RGradient n) [GradientStop n]
rGradStops of
[] -> []
xs :: [GradientStop n]
xs@(GradientStop n
x:[GradientStop n]
_) -> GradientStop n
x GradientStop n -> [GradientStop n] -> [GradientStop n]
forall a. a -> [a] -> [a]
: [GradientStop n]
xs
ss :: [GradientStop n]
ss = (GradientStop n -> n -> GradientStop n)
-> [GradientStop n] -> [n] -> [GradientStop n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\GradientStop n
gs n
sf -> GradientStop n
gs GradientStop n
-> (GradientStop n -> GradientStop n) -> GradientStop n
forall a b. a -> (a -> b) -> b
& (n -> Identity n) -> GradientStop n -> Identity (GradientStop n)
forall n. Lens' (GradientStop n) n
stopFraction ((n -> Identity n) -> GradientStop n -> Identity (GradientStop n))
-> n -> GradientStop n -> GradientStop n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
sf ) [GradientStop n]
gradStops [n]
stopFracs
renderFillTextureDefs :: SVGFloat n => Int -> Style v n -> Element
renderFillTextureDefs :: Int -> Style v n -> Element
renderFillTextureDefs Int
i Style v n
s =
case (FillTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr FillTexture n -> Texture n
forall n. FillTexture n -> Texture n
getFillTexture Style v n
s of
Just (LG LGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ LGradient n -> Int -> Element
forall n. SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient LGradient n
g Int
i
Just (RG RGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ RGradient n -> Int -> Element
forall n. SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient RGradient n
g Int
i
Maybe (Texture n)
_ -> Element
forall a. Monoid a => a
mempty
renderFillTexture :: SVGFloat n => Int -> Style v n -> [Attribute]
renderFillTexture :: Int -> Style v n -> [Attribute]
renderFillTexture Int
ident Style v n
s = case (FillTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr FillTexture n -> Texture n
forall n. FillTexture n -> Texture n
getFillTexture Style v n
s of
Just (SC (SomeColor c
c)) -> AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Fill_ Maybe Text
fillColorRgb [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<>
AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Fill_opacity_ Maybe Double
fillColorOpacity
where
fillColorRgb :: Maybe Text
fillColorRgb = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ c -> Text
forall c. Color c => c -> Text
colorToRgbText c
c
fillColorOpacity :: Maybe Double
fillColorOpacity = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ c -> Double
forall c. Color c => c -> Double
colorToOpacity c
c
Just (LG LGradient n
_) -> [AttrTag
Fill_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Fill_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
Just (RG RGradient n
_) -> [AttrTag
Fill_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Fill_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
Maybe (Texture n)
Nothing -> []
renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> Element
renderLineTextureDefs :: Int -> Style v n -> Element
renderLineTextureDefs Int
i Style v n
s =
case (LineTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr LineTexture n -> Texture n
forall n. LineTexture n -> Texture n
getLineTexture Style v n
s of
Just (LG LGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ LGradient n -> Int -> Element
forall n. SVGFloat n => LGradient n -> Int -> Element
renderLinearGradient LGradient n
g Int
i
Just (RG RGradient n
g) -> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
defs_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ RGradient n -> Int -> Element
forall n. SVGFloat n => RGradient n -> Int -> Element
renderRadialGradient RGradient n
g Int
i
Maybe (Texture n)
_ -> Element
forall a. Monoid a => a
mempty
renderLineTexture :: SVGFloat n => Int -> Style v n -> [Attribute]
renderLineTexture :: Int -> Style v n -> [Attribute]
renderLineTexture Int
ident Style v n
s = case (LineTexture n -> Texture n) -> Style v n -> Maybe (Texture n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr LineTexture n -> Texture n
forall n. LineTexture n -> Texture n
getLineTexture Style v n
s of
Just (SC (SomeColor c
c)) -> AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_ Maybe Text
lineColorRgb [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<>
AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_opacity_ Maybe Double
lineColorOpacity
where
lineColorRgb :: Maybe Text
lineColorRgb = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ c -> Text
forall c. Color c => c -> Text
colorToRgbText c
c
lineColorOpacity :: Maybe Double
lineColorOpacity = Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double) -> Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ c -> Double
forall c. Color c => c -> Double
colorToOpacity c
c
Just (LG LGradient n
_) -> [AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
Just (RG RGradient n
_) -> [AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- (Text
"url(#gradient" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
ident)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"), AttrTag
Stroke_opacity_ AttrTag -> Text -> Attribute
<<- Text
"1"]
Maybe (Texture n)
Nothing -> []
dataUri :: String -> BS8.ByteString -> AttributeValue
dataUri :: String -> ByteString -> Text
dataUri String
mime ByteString
dat = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"data:"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
mimeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";base64," String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS8.unpack (ByteString -> ByteString
BS64.encode ByteString
dat)
renderDImageEmb :: SVGFloat n => DImage n Embedded -> Element
renderDImageEmb :: DImage n Embedded -> Element
renderDImageEmb di :: DImage n Embedded
di@(DImage (ImageRaster DynamicImage
dImg) Int
_ Int
_ Transformation V2 n
_) =
DImage n Embedded -> Text -> Element
forall n any. SVGFloat n => DImage n any -> Text -> Element
renderDImage DImage n Embedded
di (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Text
dataUri String
"image/png" ByteString
img
where
img :: ByteString
img = case DynamicImage -> Either String ByteString
encodeDynamicPng DynamicImage
dImg of
Left String
str -> String -> ByteString
forall a. HasCallStack => String -> a
error String
str
Right ByteString
img' -> ByteString
img'
renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> Element
renderDImage :: DImage n any -> Text -> Element
renderDImage (DImage ImageData any
_ Int
w Int
h Transformation V2 n
tr) Text
uridata =
[Attribute] -> Element
forall result. Term result => [Attribute] -> result
image_
[ AttrTag
Transform_ AttrTag -> Text -> Attribute
<<- Text
transformMatrix
, AttrTag
Width_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
w)
, AttrTag
Height_ AttrTag -> Text -> Attribute
<<- (String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
h)
, AttrTag
XlinkHref_ AttrTag -> Text -> Attribute
<<- Text
uridata ]
where
[[n
a,n
b],[n
c,n
d],[n
e,n
f]] = Transformation V2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (Transformation V2 n
tr Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Monoid a => a -> a -> a
`mappend` Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY
Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Monoid a => a -> a -> a
`mappend` Transformation V2 n
tX Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Monoid a => a -> a -> a
`mappend` Transformation V2 n
tY)
transformMatrix :: Text
transformMatrix = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a n
b n
c n
d n
e n
f
tX :: Transformation V2 n
tX = n -> Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R1 v, Num n) =>
n -> Transformation v n
translationX (n -> Transformation V2 n) -> n -> Transformation V2 n
forall a b. (a -> b) -> a -> b
$ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
w)n -> n -> n
forall a. Fractional a => a -> a -> a
/n
2
tY :: Transformation V2 n
tY = n -> Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
n -> Transformation v n
translationY (n -> Transformation V2 n) -> n -> Transformation V2 n
forall a b. (a -> b) -> a -> b
$ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
h)n -> n -> n
forall a. Fractional a => a -> a -> a
/n
2
renderText :: SVGFloat n => Text n -> Element
renderText :: Text n -> Element
renderText (Text T2 n
tt TextAlignment n
tAlign String
str) =
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
text_
[ AttrTag
Transform_ AttrTag -> Text -> Attribute
<<- Text
transformMatrix
, AttrTag
Dominant_baseline_ AttrTag -> Text -> Attribute
<<- Text
vAlign
, AttrTag
Text_anchor_ AttrTag -> Text -> Attribute
<<- Text
hAlign
, AttrTag
Stroke_ AttrTag -> Text -> Attribute
<<- Text
"none" ]
(Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element
forall a. ToElement a => a -> Element
toElement String
str
where
vAlign :: Text
vAlign = case TextAlignment n
tAlign of
TextAlignment n
BaselineText -> Text
"alphabetic"
BoxAlignedText n
_ n
h -> case n
h of
n
h' | n
h' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
0.25 -> Text
"text-after-edge"
n
h' | n
h' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0.75 -> Text
"text-before-edge"
n
_ -> Text
"middle"
hAlign :: Text
hAlign = case TextAlignment n
tAlign of
TextAlignment n
BaselineText -> Text
"start"
BoxAlignedText n
w n
_ -> case n
w of
n
w' | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
0.25 -> Text
"start"
n
w' | n
w' n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
0.75 -> Text
"end"
n
_ -> Text
"middle"
t :: T2 n
t = T2 n
tt T2 n -> T2 n -> T2 n
forall a. Monoid a => a -> a -> a
`mappend` T2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY
[[n
a,n
b],[n
c,n
d],[n
e,n
f]] = T2 n -> [[n]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep T2 n
t
transformMatrix :: Text
transformMatrix = n -> n -> n -> n -> n -> n -> Text
forall a. RealFloat a => a -> a -> a -> a -> a -> a -> Text
matrix n
a n
b n
c n
d n
e n
f
renderStyles :: SVGFloat n => Int -> Int -> Style v n -> [Attribute]
renderStyles :: Int -> Int -> Style v n -> [Attribute]
renderStyles Int
fillId Int
lineId Style v n
s = ((Style v n -> [Attribute]) -> [Attribute])
-> [Style v n -> [Attribute]] -> [Attribute]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Style v n -> [Attribute]) -> Style v n -> [Attribute]
forall a b. (a -> b) -> a -> b
$ Style v n
s) ([Style v n -> [Attribute]] -> [Attribute])
-> [Style v n -> [Attribute]] -> [Attribute]
forall a b. (a -> b) -> a -> b
$
[ Int -> Style v n -> [Attribute]
forall n (v :: * -> *).
SVGFloat n =>
Int -> Style v n -> [Attribute]
renderLineTexture Int
lineId
, Int -> Style v n -> [Attribute]
forall n (v :: * -> *).
SVGFloat n =>
Int -> Style v n -> [Attribute]
renderFillTexture Int
fillId
, Style v n -> [Attribute]
forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderLineWidth
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderLineCap
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderLineJoin
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFillRule
, Style v n -> [Attribute]
forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderDashing
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderOpacity
, Style v n -> [Attribute]
forall n (v :: * -> *). SVGFloat n => Style v n -> [Attribute]
renderFontSize
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontSlant
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontWeight
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderFontFamily
, Style v n -> [Attribute]
forall (v :: * -> *) n. Style v n -> [Attribute]
renderMiterLimit ]
renderMiterLimit :: Style v n -> [Attribute]
renderMiterLimit :: Style v n -> [Attribute]
renderMiterLimit Style v n
s = AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_miterlimit_ Maybe Double
miterLimit
where miterLimit :: Maybe Double
miterLimit = LineMiterLimit -> Double
getLineMiterLimit (LineMiterLimit -> Double) -> Maybe LineMiterLimit -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe LineMiterLimit
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
renderOpacity :: Style v n -> [Attribute]
renderOpacity :: Style v n -> [Attribute]
renderOpacity Style v n
s = AttrTag -> Maybe Double -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Opacity_ Maybe Double
o
where o :: Maybe Double
o = Opacity -> Double
getOpacity (Opacity -> Double) -> Maybe Opacity -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe Opacity
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
renderFillRule :: Style v n -> [Attribute]
renderFillRule :: Style v n -> [Attribute]
renderFillRule Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Fill_rule_ Maybe Text
fr
where fr :: Maybe Text
fr = (FillRule -> Text
fillRuleToText (FillRule -> Text) -> (FillRule -> FillRule) -> FillRule -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> FillRule
getFillRule) (FillRule -> Text) -> Maybe FillRule -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe FillRule
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
fillRuleToText :: FillRule -> AttributeValue
fillRuleToText :: FillRule -> Text
fillRuleToText FillRule
Winding = Text
"nonzero"
fillRuleToText FillRule
EvenOdd = Text
"evenodd"
renderLineWidth :: SVGFloat n => Style v n -> [Attribute]
renderLineWidth :: Style v n -> [Attribute]
renderLineWidth Style v n
s = AttrTag -> Maybe n -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_width_ Maybe n
lWidth
where lWidth :: Maybe n
lWidth = (LineWidth n -> n) -> Style v n -> Maybe n
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr LineWidth n -> n
forall n. LineWidth n -> n
getLineWidth Style v n
s
renderLineCap :: Style v n -> [Attribute]
renderLineCap :: Style v n -> [Attribute]
renderLineCap Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_linecap_ Maybe Text
lCap
where lCap :: Maybe Text
lCap = (LineCap -> Text
lineCapToText (LineCap -> Text) -> (LineCap -> LineCap) -> LineCap -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap) (LineCap -> Text) -> Maybe LineCap -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe LineCap
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
lineCapToText :: LineCap -> AttributeValue
lineCapToText :: LineCap -> Text
lineCapToText LineCap
LineCapButt = Text
"butt"
lineCapToText LineCap
LineCapRound = Text
"round"
lineCapToText LineCap
LineCapSquare = Text
"square"
renderLineJoin :: Style v n -> [Attribute]
renderLineJoin :: Style v n -> [Attribute]
renderLineJoin Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_linejoin_ Maybe Text
lj
where lj :: Maybe Text
lj = (LineJoin -> Text
lineJoinToText (LineJoin -> Text) -> (LineJoin -> LineJoin) -> LineJoin -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin) (LineJoin -> Text) -> Maybe LineJoin -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe LineJoin
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
lineJoinToText :: LineJoin -> AttributeValue
lineJoinToText :: LineJoin -> Text
lineJoinToText LineJoin
LineJoinMiter = Text
"miter"
lineJoinToText LineJoin
LineJoinRound = Text
"round"
lineJoinToText LineJoin
LineJoinBevel = Text
"bevel"
renderDashing :: SVGFloat n => Style v n -> [Attribute]
renderDashing :: Style v n -> [Attribute]
renderDashing Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Stroke_dasharray_ Maybe Text
arr [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<>
AttrTag -> Maybe n -> [Attribute]
forall s. Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
Stroke_dashoffset_ Maybe n
dOffset
where
getDasharray :: Dashing n -> [n]
getDasharray (Dashing [n]
a n
_) = [n]
a
getDashoffset :: Dashing n -> n
getDashoffset (Dashing [n]
_ n
o) = n
o
dashArrayToStr :: [n] -> String
dashArrayToStr = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> ([n] -> [String]) -> [n] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> String) -> [n] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map n -> String
forall a. Show a => a -> String
show
checkEmpty :: Maybe (Dashing n) -> Maybe (Dashing n)
checkEmpty (Just (Dashing [] n
_)) = Maybe (Dashing n)
forall a. Maybe a
Nothing
checkEmpty Maybe (Dashing n)
other = Maybe (Dashing n)
other
dashing' :: Maybe (Dashing n)
dashing' = Maybe (Dashing n) -> Maybe (Dashing n)
forall n. Maybe (Dashing n) -> Maybe (Dashing n)
checkEmpty (Maybe (Dashing n) -> Maybe (Dashing n))
-> Maybe (Dashing n) -> Maybe (Dashing n)
forall a b. (a -> b) -> a -> b
$ (Dashing n -> Dashing n) -> Style v n -> Maybe (Dashing n)
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr Dashing n -> Dashing n
forall n. Dashing n -> Dashing n
getDashing Style v n
s
arr :: Maybe Text
arr = (String -> Text
pack (String -> Text) -> (Dashing n -> String) -> Dashing n -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [n] -> String
dashArrayToStr ([n] -> String) -> (Dashing n -> [n]) -> Dashing n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dashing n -> [n]
forall n. Dashing n -> [n]
getDasharray) (Dashing n -> Text) -> Maybe (Dashing n) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Dashing n)
dashing'
dOffset :: Maybe n
dOffset = Dashing n -> n
forall n. Dashing n -> n
getDashoffset (Dashing n -> n) -> Maybe (Dashing n) -> Maybe n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Dashing n)
dashing'
renderFontSize :: SVGFloat n => Style v n -> [Attribute]
renderFontSize :: Style v n -> [Attribute]
renderFontSize Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_size_ Maybe Text
fs
where
fs :: Maybe Text
fs = String -> Text
pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FontSize n -> String) -> Style v n -> Maybe String
forall (a :: * -> *) n t (v :: * -> *).
AttributeClass (a n) =>
(a n -> t) -> Style v n -> Maybe t
getNumAttr ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"px") (String -> String)
-> (FontSize n -> String) -> FontSize n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> String
forall a. Show a => a -> String
show (n -> String) -> (FontSize n -> n) -> FontSize n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSize n -> n
forall n. FontSize n -> n
getFontSize) Style v n
s
renderFontSlant :: Style v n -> [Attribute]
renderFontSlant :: Style v n -> [Attribute]
renderFontSlant Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_style_ Maybe Text
fs
where
fs :: Maybe Text
fs = (FontSlant -> Text
fontSlantAttr (FontSlant -> Text)
-> (FontSlant -> FontSlant) -> FontSlant -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSlant -> FontSlant
getFontSlant) (FontSlant -> Text) -> Maybe FontSlant -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe FontSlant
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
fontSlantAttr :: FontSlant -> AttributeValue
fontSlantAttr :: FontSlant -> Text
fontSlantAttr FontSlant
FontSlantItalic = Text
"italic"
fontSlantAttr FontSlant
FontSlantOblique = Text
"oblique"
fontSlantAttr FontSlant
FontSlantNormal = Text
"normal"
renderFontWeight :: Style v n -> [Attribute]
renderFontWeight :: Style v n -> [Attribute]
renderFontWeight Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_weight_ Maybe Text
fw
where
fw :: Maybe Text
fw = (FontWeight -> Text
fontWeightAttr (FontWeight -> Text)
-> (FontWeight -> FontWeight) -> FontWeight -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontWeight -> FontWeight
getFontWeight) (FontWeight -> Text) -> Maybe FontWeight -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe FontWeight
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
fontWeightAttr :: FontWeight -> AttributeValue
fontWeightAttr :: FontWeight -> Text
fontWeightAttr FontWeight
FontWeightNormal = Text
"normal"
fontWeightAttr FontWeight
FontWeightBold = Text
"bold"
fontWeightAttr FontWeight
FontWeightLighter = Text
"lighter"
fontWeightAttr FontWeight
FontWeightBolder = Text
"bolder"
fontWeightAttr FontWeight
FontWeightThin = Text
"100"
fontWeightAttr FontWeight
FontWeightUltraLight = Text
"200"
fontWeightAttr FontWeight
FontWeightLight = Text
"300"
fontWeightAttr FontWeight
FontWeightMedium = Text
"400"
fontWeightAttr FontWeight
FontWeightSemiBold = Text
"600"
fontWeightAttr FontWeight
FontWeightUltraBold = Text
"800"
fontWeightAttr FontWeight
FontWeightHeavy = Text
"900"
renderFontFamily :: Style v n -> [Attribute]
renderFontFamily :: Style v n -> [Attribute]
renderFontFamily Style v n
s = AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
Font_family_ Maybe Text
ff
where
ff :: Maybe Text
ff = (String -> Text
pack (String -> Text) -> (Font -> String) -> Font -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> String
getFont) (Font -> Text) -> Maybe Font -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style v n -> Maybe Font
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
s
renderAttr :: Show s => AttrTag -> Maybe s -> [Attribute]
renderAttr :: AttrTag -> Maybe s -> [Attribute]
renderAttr AttrTag
attr Maybe s
valM = [Attribute] -> (s -> [Attribute]) -> Maybe s -> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\s
v -> [(AttrTag -> Text -> Attribute
bindAttr AttrTag
attr) (String -> Text
pack (String -> Text) -> (s -> String) -> s -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall a. Show a => a -> String
show (s -> Text) -> s -> Text
forall a b. (a -> b) -> a -> b
$ s
v)]) Maybe s
valM
renderTextAttr :: AttrTag -> Maybe AttributeValue -> [Attribute]
renderTextAttr :: AttrTag -> Maybe Text -> [Attribute]
renderTextAttr AttrTag
attr Maybe Text
valM = [Attribute] -> (Text -> [Attribute]) -> Maybe Text -> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
v -> [(AttrTag -> Text -> Attribute
bindAttr AttrTag
attr) Text
v]) Maybe Text
valM
colorToRgbText :: forall c . Color c => c -> AttributeValue
colorToRgbText :: c -> Text
colorToRgbText c
c = [Text] -> Text
T.concat
[ Text
"rgb("
, Double -> Text
forall a. RealFrac a => a -> Text
int Double
r, Text
","
, Double -> Text
forall a. RealFrac a => a -> Text
int Double
g, Text
","
, Double -> Text
forall a. RealFrac a => a -> Text
int Double
b
, Text
")" ]
where
int :: a -> Text
int a
d = String -> Text
pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ (a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (a
d a -> a -> a
forall a. Num a => a -> a -> a
* a
255) :: Int)
(Double
r,Double
g,Double
b,Double
_) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c
colorToOpacity :: forall c . Color c => c -> Double
colorToOpacity :: c -> Double
colorToOpacity c
c = Double
a
where (Double
_,Double
_,Double
_,Double
a) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c