module Diagrams.Backend.SVG
( SVG(..)
, B
, Options(..), size, svgDefinitions
, renderSVG
) where
import Data.Foldable (foldMap)
import Data.Tree
import Diagrams.Core.Compile
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.Prelude hiding (view)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Path (Clip (Clip))
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 qualified Graphics.Rendering.SVG as R
data SVG = SVG
deriving (Show, Typeable)
type B = SVG
data SvgRenderState = SvgRenderState { _clipPathId :: Int, _ignoreFill :: Bool }
makeLenses ''SvgRenderState
initialSvgRenderState :: SvgRenderState
initialSvgRenderState = SvgRenderState 0 False
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
renderRTree :: RTree SVG R2 a -> Render SVG R2
renderRTree (Node (RPrim accTr p) _) = (render SVG (transform accTr p))
renderRTree (Node (RStyle sty) ts)
= R $ do
let R r = foldMap renderRTree ts
ignoreFill .= False
svg <- r
ign <- use ignoreFill
clippedSvg <- renderSvgWithClipping svg sty
return $ (S.g ! R.renderStyles ign sty) clippedSvg
renderRTree (Node (RFrozenTr tr) ts)
= R $ do
let R r = foldMap renderRTree ts
svg <- r
return $ R.renderTransform tr svg
renderRTree (Node _ ts) = foldMap renderRTree ts
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
}
doRender _ opts (R r) =
evalState svgOutput initialSvgRenderState
where
svgOutput = do
svg <- r
let (w,h) = case opts^.size of
Width w' -> (w',w')
Height h' -> (h',h')
Dims w' h' -> (w',h')
Absolute -> (100,100)
return $ R.svgHeader w h (opts^.svgDefinitions) $ svg
adjustDia c opts d = adjustDia2D _size setSvgSize c opts
(d # reflectY
# recommendFillColor
(transparent :: AlphaColour Double)
)
where setSvgSize sz o = o { _size = sz }
renderData _ = renderRTree . toRTree
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 (Segment Closed R2) SVG where
render c = render c . (fromSegments :: [Segment Closed R2] -> Path R2) . (:[])
instance Renderable (Trail R2) SVG where
render c = render c . pathFromTrail
instance Renderable (Path R2) SVG where
render _ p = R $ do
when (any (isLine . unLoc) . op Path $ p) $ (ignoreFill .= True)
return (R.renderPath p)
instance Renderable Text SVG where
render _ = R . return . R.renderText
renderSVG :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO ()
renderSVG outFile sizeSpec
= BS.writeFile outFile
. renderSvg
. renderDia SVG (SVGOptions sizeSpec Nothing)