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 qualified Text.Blaze.Svg11 as S
import Text.Blaze.Svg11 ((!))
import Data.Colour (transparent)
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
-> S.Svg
renderSvgWithClipping svg s id_ = do
R.renderClip (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
{ fileName :: String
, size :: SizeSpec2D
}
withStyle _ s _ (R r) =
R $ do
incrementClipPath
clipPathId_ <- gets clipPathId
svg <- r
let styledSvg = renderStyledGroup s ! (R.renderClipPathId s clipPathId_) $ renderSvgWithClipping svg s clipPathId_
return 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
# fcA transparent
)
where setSvgSize sz o = o { size = sz }
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