diagrams-svg-1.1: src/Diagrams/Backend/SVG.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
----------------------------------------------------------------------------
-- |
-- Module : Diagrams.Backend.SVG
-- Copyright : (c) 2011-2012 diagrams-svg team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- A full-featured rendering backend for diagrams producing SVG files,
-- implemented natively in Haskell (making it easy to use on any
-- platform).
--
-- To invoke the SVG backend, you have three options.
--
-- * You can use the "Diagrams.Backend.SVG.CmdLine" module to create
-- standalone executables which output SVG images when invoked.
--
-- * You can use the 'renderSVG' function provided by this module,
-- which gives you more flexible programmatic control over when and
-- how images are output (making it easy to, for example, write a
-- single program that outputs multiple images, or one that outputs
-- images dynamically based on user input, and so on).
--
-- * For the most flexibility (/e.g./ if you want access to the
-- resulting SVG value directly in memory without writing it to
-- disk), you can manually invoke the 'renderDia' method from the
-- 'Diagrams.Core.Types.Backend' instance for @SVG@. In particular,
-- 'Diagrams.Core.Types.renderDia' has the generic type
--
-- > renderDia :: b -> Options b v -> QDiagram b v m -> Result b v
--
-- (omitting a few type class constraints). @b@ represents the
-- backend type, @v@ the vector space, and @m@ the type of monoidal
-- query annotations on the diagram. 'Options' and 'Result' are
-- associated data and type families, respectively, which yield the
-- type of option records and rendering results specific to any
-- particular backend. For @b ~ SVG@ and @v ~ R2@, we have
--
-- > data Options SVG R2 = SVGOptions
-- > { size :: SizeSpec2D -- ^ The requested size.
-- > , svgDefinitions :: Maybe S.Svg
-- > -- ^ Custom definitions that will be added to the @defs@
-- > -- section of the output.
-- > }
--
-- @
-- data family Render SVG R2 = R 'SvgRenderM'
-- @
--
-- @
-- type family Result SVG R2 = 'Text.Blaze.Svg11.Svg'
-- @
--
-- So the type of 'renderDia' resolves to
--
-- @
-- renderDia :: SVG -> Options SVG R2 -> QDiagram SVG R2 m -> 'Text.Blaze.Svg11.Svg'
-- @
--
-- which you could call like @renderDia SVG (SVGOptions (Width 250))
-- myDiagram@. (In some situations GHC may not be able to infer the
-- type @m@, in which case you can use a type annotation to specify
-- it; it may be useful to simply use the type synonym @Diagram SVG
-- R2 = QDiagram SVG R2 Any@.) This returns an
-- 'Text.Blaze.Svg11.Svg' value, which you can, /e.g./ render to a
-- 'ByteString' using 'Text.Blaze.Svg.Renderer.Utf8.renderSvg'.
--
-----------------------------------------------------------------------------
module Diagrams.Backend.SVG
( SVG(..) -- rendering token
, B
, Options(..), size, svgDefinitions -- for rendering options specific to SVG
, renderSVG
) where
-- for testing
import Data.Foldable (foldMap)
import Data.Tree
-- from base
import Control.Monad.State
import Data.Typeable
import GHC.Generics (Generic)
-- from hashable
import Data.Hashable (Hashable (..))
-- from bytestring
import qualified Data.ByteString.Lazy as BS
-- from lens
import Control.Lens hiding (transform, ( # ))
-- from diagrams-core
import Diagrams.Core.Compile
import Diagrams.Core.Types (Annotation (..))
-- from diagrams-lib
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
-- from blaze-svg
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)
-- from this package
import qualified Graphics.Rendering.SVG as R
-- | @SVG@ is simply a token used to identify this rendering backend
-- (to aid type inference).
data SVG = SVG
deriving (Show, Typeable)
type B = SVG
data SvgRenderState = SvgRenderState { _clipPathId :: Int
, _fillGradId :: Int
, _lineGradId :: Int
, _isLocalText :: Bool }
makeLenses ''SvgRenderState
-- Fill gradients ids are even, line gradient ids are odd.
initialSvgRenderState :: SvgRenderState
initialSvgRenderState = SvgRenderState 0 0 1 True
-- | Monad to keep track of state when rendering an SVG.
-- Currently just keeps a monotonically increasing counter
-- for assiging a unique clip path ID.
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)
-- Handle clip attributes.
renderSvgWithClipping :: S.Svg -- ^ Input SVG
-> Style v -- ^ Styles
-> SvgRenderM -- ^ Resulting svg
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
-- | Create a new texture defs svg element using the style and the current
-- id number, then increment the gradient id number.
fillTextureDefs :: Style v -> SvgRenderM
fillTextureDefs s = do
id_ <- use fillGradId
fillGradId += 2 -- always even
return $ R.renderFillTextureDefs id_ s
lineTextureDefs :: Style v -> SvgRenderM
lineTextureDefs s = do
id_ <- use lineGradId
lineGradId += 2 -- always odd
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 -- ^ The requested size.
, _svgDefinitions :: Maybe S.Svg
-- ^ Custom definitions that will be added to the @defs@
-- section of the output.
}
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
-- save current setting for local text
oldIsLocal <- use isLocalText
-- check if this style speficies a font size in Local units
case getFontSizeIsLocal <$> getAttr sty of
Nothing -> return ()
Just isLocal -> isLocalText .= isLocal
-- render subtrees
svg <- r
-- restore the old setting for local text
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
-- TODO: instance Renderable Image SVG where
-- | Render a diagram as an SVG, writing to the specified output file
-- and using the requested size.
renderSVG :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO ()
renderSVG outFile sizeSpec
= BS.writeFile outFile
. renderSvg
. renderDia SVG (SVGOptions sizeSpec Nothing)