module Diagrams.Backend.SVG
( SVG(..)
, Options(..)
) where
import Data.Typeable
import Control.Monad.State
import Diagrams.Prelude
import Diagrams.TwoD.Path (getClip)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Text
import Data.Monoid.Split (Split(..))
import qualified Text.Blaze.Svg11 as S
import Text.Blaze.Svg11 ((!))
import qualified Graphics.Rendering.SVG as R
data SVG = SVG
deriving (Show, Typeable)
data SvgRenderState = SvgRenderState { clipPathId :: Int }
initialSvgRenderState :: SvgRenderState
initialSvgRenderState = SvgRenderState 0
type SvgRenderM = State SvgRenderState S.Svg
incrementClipPath :: State SvgRenderState ()
incrementClipPath = modify (\(SvgRenderState x) -> SvgRenderState (x + 1))
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)
renderStyledGroup :: Style v -> (S.Svg -> S.Svg)
renderStyledGroup s = S.g ! R.renderStyles s
renderSvgWithClipping :: S.Svg
-> Style v
-> Int
-> Transformation R2
-> S.Svg
renderSvgWithClipping svg s id_ t = do
R.renderClip (transform (inv t) <$> getClip <$> getAttr s) id_
svg
instance Backend SVG R2 where
data Render SVG R2 = R SvgRenderM
type Result SVG R2 = S.Svg
data Options SVG R2 = SVGOptions
{ size :: SizeSpec2D
}
withStyle _ s t (R r) =
R $ do
incrementClipPath
clipPathId_ <- gets clipPathId
svg <- r
let styledSvg = renderStyledGroup s ! (R.renderClipPathId s clipPathId_) $
renderSvgWithClipping svg s clipPathId_ t
return (R.renderTransform t styledSvg)
doRender _ (SVGOptions sz) (R r) =
evalState svgOutput initialSvgRenderState
where
svgOutput = do
svg <- r
let (w,h) = case sz of
Width w' -> (w',w')
Height h' -> (h',h')
Dims w' h' -> (w',h')
Absolute -> (100,100)
return $ R.svgHeader w h $ svg
adjustDia c opts d = adjustDia2D size setSvgSize c opts
(d # reflectY
# recommendFillColor
(transparent :: AlphaColour Double)
)
where setSvgSize sz o = o { size = sz }
renderDia SVG opts d =
doRender SVG opts' . mconcat . map renderOne . prims $ d'
where (opts', d') = adjustDia SVG opts d
renderOne :: (Prim SVG R2, (Split (Transformation R2), Style R2))
-> Render SVG R2
renderOne (p, (M t, s))
= withStyle SVG s mempty (render SVG (transform t p))
renderOne (p, (t1 :| t2, s))
= withStyle SVG s t1 (render SVG (transform t2 p))
instance Renderable (Segment R2) SVG where
render c = render c . flip Trail False . (:[])
instance Renderable (Trail R2) SVG where
render c t = render c $ Path [(p2 (0,0), t)]
instance Renderable (Path R2) SVG where
render _ = R . return . R.renderPath
instance Renderable Text SVG where
render _ = R . return . R.renderText