module Diagrams.Backend.SVG
( SVG(..)
, B
, Options(..), size, svgDefinitions
, renderSVG
) where
import Data.Foldable (foldMap)
import Data.Tree
import Control.Monad.State
import Data.Typeable
import GHC.Generics (Generic)
import Data.Hashable (Hashable (..))
import qualified Data.ByteString.Lazy as BS
import Control.Lens hiding (transform, ( # ))
import Diagrams.Core.Compile
import Diagrams.Core.Types (Annotation (..))
import Diagrams.Prelude hiding (view)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Attributes (splitTextureFills)
import Diagrams.TwoD.Path (Clip (Clip))
import Diagrams.TwoD.Size (sizePair)
import Diagrams.TwoD.Text
import Text.Blaze.Internal (ChoiceString (..), MarkupM (..),
StaticString (..))
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)
import Text.Blaze.Svg11 ((!))
import qualified Text.Blaze.Svg11 as S
import Text.Blaze.Svg11.Attributes (xlinkHref)
import qualified Graphics.Rendering.SVG as R
data SVG = SVG
deriving (Show, Typeable)
type B = SVG
data SvgRenderState = SvgRenderState { _clipPathId :: Int
, _fillGradId :: Int
, _lineGradId :: Int
, _isLocalText :: Bool }
makeLenses ''SvgRenderState
initialSvgRenderState :: SvgRenderState
initialSvgRenderState = SvgRenderState 0 0 1 True
type SvgRenderM = State SvgRenderState S.Svg
instance Monoid (Render SVG R2) where
mempty = R $ return mempty
(R r1) `mappend` (R r2_) =
R $ do
svg1 <- r1
svg2 <- r2_
return (svg1 `mappend` svg2)
renderSvgWithClipping :: S.Svg
-> Style v
-> SvgRenderM
renderSvgWithClipping svg s =
case (op Clip <$> getAttr s) of
Nothing -> return $ svg
Just paths -> renderClips paths
where
renderClips :: [Path R2] -> SvgRenderM
renderClips [] = return $ svg
renderClips (p:ps) = do
clipPathId += 1
id_ <- use clipPathId
R.renderClip p id_ <$> renderClips ps
fillTextureDefs :: Style v -> SvgRenderM
fillTextureDefs s = do
id_ <- use fillGradId
fillGradId += 2
return $ R.renderFillTextureDefs id_ s
lineTextureDefs :: Style v -> SvgRenderM
lineTextureDefs s = do
id_ <- use lineGradId
lineGradId += 2
return $ R.renderLineTextureDefs id_ s
instance Backend SVG R2 where
data Render SVG R2 = R SvgRenderM
type Result SVG R2 = S.Svg
data Options SVG R2 = SVGOptions
{ _size :: SizeSpec2D
, _svgDefinitions :: Maybe S.Svg
}
renderRTree _ opts rt = evalState svgOutput initialSvgRenderState
where
svgOutput = do
let R r = toRender rt
(w,h) = sizePair (opts^.size)
svg <- r
return $ R.svgHeader w h (opts^.svgDefinitions) $ svg
adjustDia c opts d = adjustDia2D size c opts (d # reflectY)
toRender :: RTree SVG R2 Annotation -> Render SVG R2
toRender = fromRTree
. Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))
. (:[])
. splitTextureFills
where
fromRTree (Node (RAnnot (Href uri)) rs)
= R $ do
let R r = foldMap fromRTree rs
svg <- r
return $ (S.a ! xlinkHref (S.toValue uri)) svg
fromRTree (Node (RPrim p) _) = render SVG p
fromRTree (Node (RStyle sty) ts)
= R $ do
let R r = foldMap fromRTree ts
oldIsLocal <- use isLocalText
case getFontSizeIsLocal <$> getAttr sty of
Nothing -> return ()
Just isLocal -> isLocalText .= isLocal
svg <- r
isLocalText .= oldIsLocal
idFill <- use fillGradId
idLine <- use lineGradId
clippedSvg <- renderSvgWithClipping svg sty
lineGradDefs <- lineTextureDefs sty
fillGradDefs <- fillTextureDefs sty
let textureDefs = fillGradDefs `mappend` lineGradDefs
return $ (S.g ! R.renderStyles idFill idLine sty)
(textureDefs `mappend` clippedSvg)
fromRTree (Node _ rs) = foldMap fromRTree rs
getSize :: Options SVG R2 -> SizeSpec2D
getSize (SVGOptions {_size = s}) = s
setSize :: Options SVG R2 -> SizeSpec2D -> Options SVG R2
setSize o s = o {_size = s}
size :: Lens' (Options SVG R2) SizeSpec2D
size = lens getSize setSize
getSVGDefs :: Options SVG R2 -> Maybe S.Svg
getSVGDefs (SVGOptions {_svgDefinitions = d}) = d
setSVGDefs :: Options SVG R2 -> Maybe S.Svg -> Options SVG R2
setSVGDefs o d = o {_svgDefinitions = d}
svgDefinitions :: Lens' (Options SVG R2) (Maybe S.Svg)
svgDefinitions = lens getSVGDefs setSVGDefs
instance Hashable (Options SVG R2) where
hashWithSalt s (SVGOptions sz defs) =
s `hashWithSalt` sz `hashWithSalt` defs
instance Hashable StaticString where
hashWithSalt s (StaticString dl bs txt)
= s `hashWithSalt` dl [] `hashWithSalt` bs `hashWithSalt` txt
deriving instance Generic ChoiceString
instance Hashable ChoiceString
instance Hashable (MarkupM a) where
hashWithSalt s (Parent w x y z) =
s `hashWithSalt`
(0 :: Int) `hashWithSalt`
w `hashWithSalt`
x `hashWithSalt`
y `hashWithSalt`
z
hashWithSalt s (CustomParent cs m) =
s `hashWithSalt`
(1 :: Int) `hashWithSalt`
cs `hashWithSalt`
m
hashWithSalt s (Leaf s1 s2 s3) =
s `hashWithSalt`
(2 :: Int) `hashWithSalt`
s1 `hashWithSalt`
s2 `hashWithSalt`
s3
hashWithSalt s (CustomLeaf cs b) =
s `hashWithSalt`
(3 :: Int) `hashWithSalt`
cs `hashWithSalt`
b
hashWithSalt s (Content cs) =
s `hashWithSalt`
(4 :: Int) `hashWithSalt`
cs
hashWithSalt s (Append m1 m2) =
s `hashWithSalt`
(5 :: Int) `hashWithSalt`
m1 `hashWithSalt`
m2
hashWithSalt s (AddAttribute s1 s2 s3 m) =
s `hashWithSalt`
(6 :: Int) `hashWithSalt`
s1 `hashWithSalt`
s2 `hashWithSalt`
s3 `hashWithSalt`
m
hashWithSalt s (AddCustomAttribute s1 s2 m) =
s `hashWithSalt`
(7 :: Int) `hashWithSalt`
s1 `hashWithSalt`
s2 `hashWithSalt`
m
hashWithSalt s Empty = s `hashWithSalt` (8 :: Int)
instance Renderable (Path R2) SVG where
render _ = R . return . R.renderPath
instance Renderable Text SVG where
render _ t = R $ do
isLocal <- use isLocalText
return $ R.renderText isLocal t
instance Renderable (DImage Embedded) SVG where
render _ = R . return . R.renderDImage
renderSVG :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO ()
renderSVG outFile sizeSpec
= BS.writeFile outFile
. renderSvg
. renderDia SVG (SVGOptions sizeSpec Nothing)