diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,19 @@ +0.7: 9 August 2013 +------------------ + +* **New features** + + - New `renderToSVG` convenience function + - Vastly improved Haddock documentation + +* **New instances** + + - `Show` instance for `Options SVG R2` + +* **Dependency/version changes** + - allow `base-4.7` and `unix-2.7` + - Upgrade to `monoid-extras-0.3` + 0.6.0.1: 14 December 2012 ------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,8 +1,9 @@ -Copyright 2011-2012 diagrams-svg team: +Copyright 2011-2013 diagrams-svg team: Deepak Jois Felipe Lessa Chris Mears + Michael Sloan Michael Thompson Ryan Yates Brent Yorgey diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ yet. However, it is functional enough that [hs-logo] uses it. Check out the [issues page][issues] to get an idea of the features that are missing. -[issues]: https://github.com/deepakjois/diagrams-svg/issues +[issues]: https://github.com/diagrams/diagrams-svg/issues [hs-logo]: http://github.com/deepakjois/hs-logo # Installation diff --git a/diagrams-svg.cabal b/diagrams-svg.cabal --- a/diagrams-svg.cabal +++ b/diagrams-svg.cabal @@ -1,5 +1,5 @@ Name: diagrams-svg -Version: 0.6.0.1 +Version: 0.7 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 @@ -12,14 +12,25 @@ Category: Graphics Build-type: Simple Cabal-version: >=1.10 -Tested-with: GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.2, GHC == 7.6.1 -Description: - This package provides a modular backend for rendering diagrams - created with the diagrams EDSL using SVG. It uses - @blaze-svg@ to be a fast, pure-Haskell backend. - . - More documentation: Github README : - +Tested-with: GHC == 7.4.2, GHC == 7.6.1 +Description: This package provides a modular backend for rendering + diagrams created with the diagrams EDSL to SVG + files. It uses @blaze-svg@ to be a fast, native + Haskell backend, making it suitable for use on + any platform. + . + The package provides the following modules: + . + * "Diagrams.Backend.SVG.CmdLine" - if you're + just getting started with diagrams, begin here. + . + * "Diagrams.Backend.SVG" - look at this next. + The general API for the SVG backend. + . + Additional documentation can be found in the + README file distributed with the source tarball or + viewable on GitHub: + . Source-repository head type: git location: http://github.com/diagrams/diagrams-svg @@ -29,7 +40,7 @@ Diagrams.Backend.SVG.CmdLine Other-modules: Graphics.Rendering.SVG Hs-source-dirs: src - Build-depends: base >= 4.3 && < 4.7 + Build-depends: base >= 4.3 && < 4.8 , old-time , process , directory @@ -38,16 +49,16 @@ , bytestring >= 0.9 && < 1.0 , vector-space >= 0.7 && < 0.9 , colour - , diagrams-core >= 0.6 && < 0.7 - , diagrams-lib >= 0.6 && < 0.7 - , monoid-extras >= 0.2 && < 0.3 + , diagrams-core >= 0.7 && < 0.8 + , diagrams-lib >= 0.7 && < 0.8 + , monoid-extras >= 0.3 && < 0.4 , blaze-svg >= 0.3.3 , cmdargs >= 0.6 && < 0.11 , split >= 0.1.2 && < 0.3 , time if !os(windows) cpp-options: -DCMDLINELOOP - Build-depends: unix >= 2.4 && < 2.7 + Build-depends: unix >= 2.4 && < 2.8 Ghc-options: -Wall diff --git a/src/Diagrams/Backend/SVG.hs b/src/Diagrams/Backend/SVG.hs --- a/src/Diagrams/Backend/SVG.hs +++ b/src/Diagrams/Backend/SVG.hs @@ -1,55 +1,127 @@ -{-# LANGUAGE TypeFamilies - , MultiParamTypeClasses - , FlexibleInstances - , FlexibleContexts - , TypeSynonymInstances - , DeriveDataTypeable - #-} -{-| - The SVG backend. --} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- 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. +-- > } +-- +-- @ +-- 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 , Options(..) -- for rendering options specific to SVG + + , renderSVG ) where -- from base -import Data.Typeable -import Control.Monad.State +import Control.Monad.State +import Data.Typeable +-- from bytestring +import qualified Data.ByteString.Lazy as BS + -- from diagrams-lib -import Diagrams.Prelude -import Diagrams.TwoD.Path (getClip) -import Diagrams.TwoD.Adjust (adjustDia2D) -import Diagrams.TwoD.Text +import Diagrams.Prelude +import Diagrams.TwoD.Adjust (adjustDia2D) +import Diagrams.TwoD.Path (getClip) +import Diagrams.TwoD.Text -- from monoid-extras -import Data.Monoid.Split (Split(..)) +import Data.Monoid.Split (Split (..)) -- from blaze-svg -import qualified Text.Blaze.Svg11 as S -import Text.Blaze.Svg11 ((!)) +import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) +import Text.Blaze.Svg11 ((!)) +import qualified Text.Blaze.Svg11 as S -- from this package -import qualified Graphics.Rendering.SVG as R +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) - -data SvgRenderState = SvgRenderState { clipPathId :: Int } +data SvgRenderState = SvgRenderState { clipPathId :: Int, ignoreFill :: Bool } initialSvgRenderState :: SvgRenderState -initialSvgRenderState = SvgRenderState 0 +initialSvgRenderState = SvgRenderState 0 False --- Monad to keep track of state when rendering an SVG. --- Currently just keeps a monotonically increasing counter --- for assiging unique clip path ID +-- | 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 incrementClipPath :: State SvgRenderState () -incrementClipPath = modify (\(SvgRenderState x) -> SvgRenderState (x + 1)) +incrementClipPath = modify (\st -> st { clipPathId = clipPathId st + 1 }) +setIgnoreFill :: Bool -> State SvgRenderState () +setIgnoreFill b = modify (\st -> st { ignoreFill = b }) + instance Monoid (Render SVG R2) where mempty = R $ return mempty (R r1) `mappend` (R r2_) = @@ -58,15 +130,15 @@ svg2 <- r2_ return (svg1 `mappend` svg2) --- renders a element with styles applied as attributes. -renderStyledGroup :: Style v -> (S.Svg -> S.Svg) -renderStyledGroup s = S.g ! R.renderStyles s +-- | Renders a element with styles applied as attributes. +renderStyledGroup :: Bool -> Style v -> (S.Svg -> S.Svg) +renderStyledGroup ignFill s = S.g ! R.renderStyles ignFill s -renderSvgWithClipping :: S.Svg -- Input SVG - -> Style v -- Styles - -> Int -- Clip Path ID - -> Transformation R2 -- Freeze transform - -> S.Svg -- Resulting svg +renderSvgWithClipping :: S.Svg -- ^ Input SVG + -> Style v -- ^ Styles + -> Int -- ^ Clip Path ID + -> Transformation R2 -- ^ Freeze transform + -> S.Svg -- ^ Resulting svg renderSvgWithClipping svg s id_ t = do R.renderClip (transform (inv t) <$> getClip <$> getAttr s) id_ -- Clipping if any svg -- The diagram @@ -77,19 +149,22 @@ data Options SVG R2 = SVGOptions { size :: SizeSpec2D -- ^ The requested size. } + deriving Show - -- Here the SVG backend is different from the other backends. We - -- give a different definition of renderDia, where only the - -- non-frozen transformation is applied to the primitives before - -- they are passed to render. This means that withStyle is - -- responsible for applying the frozen transformation to the - -- primitives. + -- | Here the SVG backend is different from the other backends. We + -- give a different definition of renderDia, where only the + -- non-frozen transformation is applied to the primitives before + -- they are passed to render. This means that withStyle is + -- responsible for applying the frozen transformation to the + -- primitives. withStyle _ s t (R r) = R $ do incrementClipPath + setIgnoreFill False clipPathId_ <- gets clipPathId svg <- r - let styledSvg = renderStyledGroup s ! (R.renderClipPathId s clipPathId_) $ + ign <- gets ignoreFill + let styledSvg = renderStyledGroup ign s ! (R.renderClipPathId s clipPathId_) $ renderSvgWithClipping svg s clipPathId_ t -- This is where the frozen transformation is applied. return (R.renderTransform t styledSvg) @@ -113,9 +188,9 @@ ) where setSvgSize sz o = o { size = sz } - -- This implementation of renderDia is the same as the default one, - -- except that it only applies the non-frozen transformation to the - -- primitives before passing them to render. + -- | This implementation of renderDia is the same as the default one, + -- except that it only applies the non-frozen transformation to the + -- primitives before passing them to render. renderDia SVG opts d = doRender SVG opts' . mconcat . map renderOne . prims $ d' where (opts', d') = adjustDia SVG opts d @@ -129,16 +204,29 @@ -- implementation: "t2" instead of "t1 <> t2". = withStyle SVG s t1 (render SVG (transform t2 p)) -instance Renderable (Segment R2) SVG where - render c = render c . flip Trail False . (:[]) +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 t = render c $ Path [(p2 (0,0), t)] + render c = render c . pathFromTrail instance Renderable (Path R2) SVG where - render _ = R . return . R.renderPath + render _ p = R $ do + -- Don't fill lines. diagrams-lib separates out lines and loops + -- for us, so if we see one line, they are all lines. + when (any (isLine . unLoc) . pathTrails $ p) $ setIgnoreFill True + return (R.renderPath p) instance Renderable Text SVG where render _ = R . return . R.renderText -- 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) diff --git a/src/Diagrams/Backend/SVG/CmdLine.hs b/src/Diagrams/Backend/SVG/CmdLine.hs --- a/src/Diagrams/Backend/SVG/CmdLine.hs +++ b/src/Diagrams/Backend/SVG/CmdLine.hs @@ -9,11 +9,33 @@ -- Convenient creation of command-line-driven executables for -- rendering diagrams using the SVG backend. -- +-- * 'defaultMain' creates an executable which can render a single +-- diagram at various options. +-- +-- * 'multiMain' is like 'defaultMain' but allows for a list of +-- diagrams from which the user can choose one to render. +-- +-- If you want to generate diagrams programmatically---/i.e./ if you +-- want to do anything more complex than what the below functions +-- provide---you have several options. +-- +-- * A simple but somewhat inflexible approach is to wrap up +-- 'defaultMain' (or 'multiMain') in a call to +-- 'System.Environment.withArgs'. +-- +-- * You can use 'Diagrams.Backend.SVG.renderSVG' to render a diagram +-- to a file directly; see "Diagrams.Backend.SVG". +-- +-- * A more flexible approach is to directly call 'renderDia'; see +-- "Diagrams.Backend.SVG" for more information. + ----------------------------------------------------------------------------- module Diagrams.Backend.SVG.CmdLine ( defaultMain , multiMain + + , SVG ) where import Diagrams.Prelude hiding (width, height, interval) @@ -23,7 +45,6 @@ import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) import qualified Data.ByteString.Lazy as BS - import Data.Maybe (fromMaybe) import Control.Monad (when) diff --git a/src/Graphics/Rendering/SVG.hs b/src/Graphics/Rendering/SVG.hs --- a/src/Graphics/Rendering/SVG.hs +++ b/src/Graphics/Rendering/SVG.hs @@ -1,4 +1,21 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ViewPatterns, OverloadedStrings, RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.SVG +-- Copyright : (c) 2011 diagrams-svg team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Generic tools for generating SVG files. +-- +----------------------------------------------------------------------------- + module Graphics.Rendering.SVG ( svgHeader , renderPath @@ -10,15 +27,16 @@ ) where -- from base -import Data.List (intersperse, intercalate) +import Data.List (intercalate, intersperse) -- from diagrams-lib -import Diagrams.Prelude hiding (Render, Attribute, close, e, (<>)) -import Diagrams.TwoD.Text -import Diagrams.TwoD.Path (getFillRule, getClip) +import Diagrams.Prelude hiding (Attribute, Render, e, (<>)) +import Diagrams.TwoD.Path (getClip, getFillRule) +import Diagrams.TwoD.Text -import Text.Blaze.Svg11 ((!), mkPath, m, cr, hr, vr, lr, z) -import qualified Text.Blaze.Svg11 as S +-- from blaze-svg +import Text.Blaze.Svg11 (cr, hr, lr, m, mkPath, vr, z, (!)) +import qualified Text.Blaze.Svg11 as S import qualified Text.Blaze.Svg11.Attributes as A svgHeader :: Double -> Double -> S.Svg -> S.Svg @@ -35,18 +53,20 @@ where makePath = mkPath $ mapM_ renderTrail trs -renderTrail :: (P2, Trail R2) -> S.Path -renderTrail (unp2 -> (x,y), Trail segs closed) = do +renderTrail :: Located (Trail R2) -> S.Path +renderTrail (viewLoc -> (unp2 -> (x,y), t)) = flip withLine t $ \l -> do m x y - mapM_ renderSeg segs - if closed then z else return () - -renderSeg :: Segment R2 -> S.Path -renderSeg (Linear (unr2 -> (x,0))) = hr x -renderSeg (Linear (unr2 -> (0,y))) = vr y -renderSeg (Linear (unr2 -> (x,y))) = lr x y -renderSeg (Cubic (unr2 -> (x0,y0)) (unr2 -> (x1,y1)) (unr2 -> (x2,y2))) = cr x0 y0 x1 y1 x2 y2 + mapM_ renderSeg (lineSegments l) + if isLoop t then z else return () +renderSeg :: Segment Closed R2 -> S.Path +renderSeg (Linear (OffsetClosed (unr2 -> (x,0)))) = hr x +renderSeg (Linear (OffsetClosed (unr2 -> (0,y)))) = vr y +renderSeg (Linear (OffsetClosed (unr2 -> (x,y)))) = lr x y +renderSeg (Cubic (unr2 -> (x0,y0)) + (unr2 -> (x1,y1)) + (OffsetClosed (unr2 -> (x2,y2)))) + = cr x0 y0 x1 y1 x2 y2 renderClip :: Maybe [Path R2] -> Int -> S.Svg renderClip Nothing _ = mempty @@ -75,15 +95,17 @@ (unr2 -> (b1,b2)) = apply t unitY (unr2 -> (c1,c2)) = transl t --- Apply a transformation to some already-rendered SVG. +-- | Apply a transformation to some already-rendered SVG. renderTransform :: Transformation R2 -> S.Svg -> S.Svg renderTransform t svg = S.g svg ! (A.transform $ S.matrix a1 a2 b1 b2 c1 c2) where (a1,a2,b1,b2,c1,c2) = getMatrix t -renderStyles :: forall v. Style v -> S.Attribute -renderStyles s = mconcat . map ($ s) $ +renderStyles :: Bool -> Style v -> S.Attribute +renderStyles ignoreFill s = mconcat . map ($ s) $ [ renderLineColor - , renderFillColor + , if ignoreFill + then const (renderAttr A.fillOpacity (Just (0 :: Double))) + else renderFillColor , renderLineWidth , renderLineCap , renderLineJoin @@ -146,7 +168,7 @@ renderDashing :: Style v -> S.Attribute renderDashing s = (renderAttr A.strokeDasharray arr) `mappend` - (renderAttr A.strokeDashoffset offset) + (renderAttr A.strokeDashoffset dOffset) where getDasharray (Dashing a _) = a getDashoffset :: Dashing -> Double @@ -154,7 +176,7 @@ dashArrayToStr = intercalate "," . map show dashing_ = getDashing <$> getAttr s arr = (dashArrayToStr . getDasharray) <$> dashing_ - offset = getDashoffset <$> dashing_ + dOffset = getDashoffset <$> dashing_ renderFontSize :: Style v -> S.Attribute renderFontSize s = renderAttr A.fontSize fontSize_ @@ -191,7 +213,7 @@ Nothing -> Nothing Just _ -> Just ("url(#myClip" ++ show id_ ++ ")") --- Render a style attribute if available, empty otherwise +-- | Render a style attribute if available, empty otherwise. renderAttr :: S.ToValue s => (S.AttributeValue -> S.Attribute) -> Maybe s -> S.Attribute @@ -208,9 +230,8 @@ , ")" ] where int d = show (round (d * 255) :: Int) - (r,g,b,_) = colorToRGBA c + (r,g,b,_) = colorToSRGBA c colorToOpacity :: forall c . Color c => c -> Double colorToOpacity c = a - where (_,_,_,a) = colorToRGBA c - + where (_,_,_,a) = colorToSRGBA c