diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## [v1.3.1.8](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.8) (2015-11-14) + +- allow `lucid-svg-0.6` + ## [v1.3.1.7](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.7) (2015-11-10) - allow `semigroups-0.18` 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: 1.3.1.7 +Version: 1.3.1.8 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 @@ -53,7 +53,7 @@ , diagrams-core >= 1.3 && < 1.4 , diagrams-lib >= 1.3 && < 1.4 , monoid-extras >= 0.3 && < 0.5 - , lucid-svg >= 0.5 && < 0.6 + , lucid-svg >= 0.6 && < 0.7 , text >= 0.11 && < 1.3 , JuicyPixels >= 3.1.5 && < 3.3 , split >= 0.1.2 && < 0.3 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 @@ -6,7 +6,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -93,7 +95,8 @@ module Diagrams.Backend.SVG ( SVG(..) -- rendering token , B - , Options(..), sizeSpec, svgDefinitions, idPrefix -- for rendering options specific to SVG + -- for rendering options specific to SVG + , Options(..), sizeSpec, svgDefinitions, idPrefix, svgAttributes, generateDoctype , SVGFloat , renderSVG @@ -233,20 +236,26 @@ newtype Render SVG V2 n = R (SvgRenderM n) type Result SVG V2 n = SvgM data Options SVG V2 n = SVGOptions - { _size :: SizeSpec V2 n -- ^ The requested size. - , _svgDefinitions :: Maybe SvgM + { _size :: SizeSpec V2 n -- ^ The requested size. + , _svgDefinitions :: Maybe SvgM -- ^ Custom definitions that will be added to the @defs@ -- section of the output. - , _idPrefix :: T.Text + , _idPrefix :: T.Text + , _svgAttributes :: [Attribute] + -- ^ Attriubtes to apply to the entire svg element. + , _generateDoctype :: Bool } + renderRTree :: SVG -> Options SVG V2 n -> RTree SVG V2 n Annotation -> Result SVG V2 n renderRTree _ opts rt = runRenderM (opts ^.idPrefix) svgOutput where svgOutput = do let R r = rtree (splitTextureFills rt) V2 w h = specToSize 100 (opts^.sizeSpec) svg <- r - return $ R.svgHeader w h (opts^.svgDefinitions) svg + return $ R.svgHeader w h (opts^.svgDefinitions) + (opts^.svgAttributes) + (opts^.generateDoctype) svg adjustDia c opts d = adjustDia2D sizeSpec c opts (d # reflectY) @@ -275,6 +284,18 @@ idPrefix :: SVGFloat n => Lens' (Options SVG V2 n) T.Text idPrefix f opts = f (_idPrefix opts) <&> \i -> opts { _idPrefix = i } +-- | Lens onto the svgAttributes field of the svg options. This field +-- is provided to supply SVG attributes to the entire diagram. +svgAttributes :: SVGFloat n => Lens' (Options SVG V2 n) [Attribute] +svgAttributes f opts = + f (_svgAttributes opts) <&> \ds -> opts { _svgAttributes = ds } + +-- | Lens onto the generateDoctype field of the svg options. Set +-- to False if you don't want a doctype tag included in the output. +generateDoctype :: SVGFloat n => Lens' (Options SVG V2 n) Bool +generateDoctype f opts = + f (_generateDoctype opts) <&> \ds -> opts { _generateDoctype = ds } + -- paths --------------------------------------------------------------- attributedRender :: SVGFloat n => SvgM -> SvgRenderM n @@ -285,7 +306,9 @@ lineGradDefs <- lineTextureDefs sty fillGradDefs <- fillTextureDefs sty return $ do - defs_ $ fillGradDefs >> lineGradDefs + let gDefs = fillGradDefs >> lineGradDefs + defs <- gDefs + unless (defs == mempty) (defs_ gDefs) g_ (R.renderStyles idFill idLine sty) clippedSvg instance SVGFloat n => Renderable (Path V2 n) SVG where @@ -300,11 +323,11 @@ -- | Render a diagram as an SVG, writing to the specified output file -- and using the requested size. renderSVG :: SVGFloat n => FilePath -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO () -renderSVG outFile spec = renderSVG' outFile (SVGOptions spec Nothing (mkPrefix outFile)) +renderSVG outFile spec = renderSVG' outFile (SVGOptions spec Nothing (mkPrefix outFile) [] True) -- | Render a diagram as a pretty printed SVG. renderPretty :: SVGFloat n => FilePath -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO () -renderPretty outFile spec = renderPretty' outFile (SVGOptions spec Nothing (mkPrefix outFile)) +renderPretty outFile spec = renderPretty' outFile (SVGOptions spec Nothing (mkPrefix outFile)[] True) -- Create a prefile using the basename of the output file. Only standard -- letters are considered. @@ -334,11 +357,11 @@ let pic t d = return $ image (DImage (ImageNative (Img t d)) (dynamicMap imageWidth dyn) (dynamicMap imageHeight dyn) mempty) - if pngHeader `SBS.isPrefixOf` raw then pic 'P' dat else do - if jpgHeader `SBS.isPrefixOf` raw then pic 'J' dat else do - case dyn of - (ImageYCbCr8 _) -> pic 'J' dat - _ -> pic 'P' =<< eIO (encodeDynamicPng dyn) + if | pngHeader `SBS.isPrefixOf` raw -> pic 'P' dat + | jpgHeader `SBS.isPrefixOf` raw -> pic 'J' dat + | otherwise -> case dyn of + (ImageYCbCr8 _) -> pic 'J' dat + _ -> pic 'P' =<< eIO (encodeDynamicPng dyn) where pngHeader :: SBS.ByteString pngHeader = SBS.pack [137, 80, 78, 71, 13, 10, 26, 10] jpgHeader :: SBS.ByteString @@ -355,5 +378,11 @@ return $ R.renderDImage di $ R.dataUri mime d instance (Hashable n, SVGFloat n) => Hashable (Options SVG V2 n) where - hashWithSalt s (SVGOptions sz defs _) = s `hashWithSalt` sz `hashWithSalt` ds - where ds = fmap renderBS defs + hashWithSalt s (SVGOptions sz defs ia sa gd) = + s `hashWithSalt` + sz `hashWithSalt` + ds `hashWithSalt` + ia `hashWithSalt` + sa `hashWithSalt` + gd + where ds = fmap renderBS defs 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 @@ -170,8 +170,8 @@ ps | last ps `elem` ["svg"] -> do let szSpec = fromIntegral <$> mkSizeSpec2D (opts^.width) (opts^.height) if isPretty pretty - then renderSVG (opts^.output) szSpec d - else renderPretty (opts^.output) szSpec d + then renderPretty (opts^.output) szSpec d + else renderSVG (opts^.output) szSpec d | otherwise -> putStrLn $ "Unknown file type: " ++ last ps -- | @multiMain@ is like 'defaultMain', except instead of a single 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 @@ -90,16 +90,18 @@ -- | @svgHeader w h defs s@: @w@ width, @h@ height, -- @defs@ global definitions for defs sections, @s@ actual SVG content. -svgHeader :: SVGFloat n => n -> n -> Maybe SvgM -> SvgM -> SvgM -svgHeader w h defines s = doctype_ <> with (svg11_ (defs_ ds <> s)) - [ width_ (toText w) - , height_ (toText h) - , font_size_ "1" - , viewBox_ (pack . unwords $ map show ([0, 0, round w, round h] :: [Int])) - , stroke_ "rgb(0,0,0)" - , stroke_opacity_ "1" ] +svgHeader :: SVGFloat n => n -> n -> Maybe SvgM -> [Attribute] -> Bool -> SvgM -> SvgM +svgHeader w h defines attributes genDoctype s = dt <> with (svg11_ (defs_ ds <> s)) + ([ width_ (toText w) + , height_ (toText h) + , font_size_ "1" + , viewBox_ (pack . unwords $ map show ([0, 0, round w, round h] :: [Int])) + , stroke_ "rgb(0,0,0)" + , stroke_opacity_ "1" ] + ++ attributes ) where ds = fromMaybe mempty defines + dt = if genDoctype then doctype_ else mempty renderPath :: SVGFloat n => Path V2 n -> SvgM renderPath trs = if makePath == T.empty then mempty else path_ [d_ makePath]