diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,17 @@ +0.8: 10 September 2013 +---------------------- + +* **New features** + + - Extra SVG definitions, to be inserted in the output, may be + passed as an argument + - Support for new miter limit attribute + - Approximate text alignment + +* **Bug fixes** + + - Stacking multiple clip regions now works properly + 0.7: 9 August 2013 ------------------ 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.7 +Version: 0.8 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 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 @@ -97,6 +97,7 @@ import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) import Text.Blaze.Svg11 ((!)) import qualified Text.Blaze.Svg11 as S +import qualified Text.Blaze.Svg.Renderer.String as StringSvg -- from this package import qualified Graphics.Rendering.SVG as R @@ -136,20 +137,29 @@ 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 + -> SvgRenderM -- ^ Resulting svg +renderSvgWithClipping svg s t = + case (transform (inv t) <$> getClip <$> getAttr s) of + Nothing -> return $ svg + Just paths -> renderClips paths + where + renderClips :: [Path R2] -> SvgRenderM + renderClips [] = return $ svg + renderClips (p:ps) = do + incrementClipPath + id_ <- gets clipPathId + R.renderClip p id_ <$> renderClips ps 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. } - deriving Show -- | Here the SVG backend is different from the other backends. We -- give a different definition of renderDia, where only the @@ -159,27 +169,25 @@ -- primitives. withStyle _ s t (R r) = R $ do - incrementClipPath setIgnoreFill False - clipPathId_ <- gets clipPathId svg <- r ign <- gets ignoreFill - let styledSvg = renderStyledGroup ign s ! (R.renderClipPathId s clipPathId_) $ - renderSvgWithClipping svg s clipPathId_ t + clippedSvg <- renderSvgWithClipping svg s t + let styledSvg = renderStyledGroup ign s clippedSvg -- This is where the frozen transformation is applied. return (R.renderTransform t styledSvg) - doRender _ (SVGOptions sz) (R r) = + doRender _ opts (R r) = evalState svgOutput initialSvgRenderState where svgOutput = do svg <- r - let (w,h) = case sz of + let (w,h) = case size opts of Width w' -> (w',w') Height h' -> (h',h') Dims w' h' -> (w',h') Absolute -> (100,100) - return $ R.svgHeader w h $ svg + return $ R.svgHeader w h (svgDefinitions opts) $ svg adjustDia c opts d = adjustDia2D size setSvgSize c opts (d # reflectY @@ -204,6 +212,19 @@ -- implementation: "t2" instead of "t1 <> t2". = withStyle SVG s t1 (render SVG (transform t2 p)) +instance Show (Options SVG R2) where + show opts = concat $ + [ "SVGOptions { " + , "size = " + , show $ size opts + , " , " + , "svgDefinitions = " + , case svgDefinitions opts of + Nothing -> "Nothing" + Just svg -> "Just " ++ StringSvg.renderSvg svg + , " }" + ] + instance Renderable (Segment Closed R2) SVG where render c = render c . (fromSegments :: [Segment Closed R2] -> Path R2) . (:[]) @@ -229,4 +250,4 @@ renderSVG outFile sizeSpec = BS.writeFile outFile . renderSvg - . renderDia SVG (SVGOptions sizeSpec) + . renderDia SVG (SVGOptions sizeSpec Nothing) 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 @@ -156,7 +156,7 @@ (Just w, Just h) -> Dims (fromIntegral w) (fromIntegral h) - build = renderDia SVG (SVGOptions sizeSpec) d + build = renderDia SVG (SVGOptions sizeSpec Nothing) d BS.writeFile (output opts) (renderSvg build) | otherwise -> putStrLn $ "Unknown file type: " ++ last ps 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 @@ -20,10 +20,10 @@ ( svgHeader , renderPath , renderClip - , renderClipPathId , renderText , renderStyles , renderTransform + , renderMiterLimit ) where -- from base @@ -31,7 +31,7 @@ -- from diagrams-lib import Diagrams.Prelude hiding (Attribute, Render, e, (<>)) -import Diagrams.TwoD.Path (getClip, getFillRule) +import Diagrams.TwoD.Path (getFillRule) import Diagrams.TwoD.Text -- from blaze-svg @@ -39,14 +39,19 @@ import qualified Text.Blaze.Svg11 as S import qualified Text.Blaze.Svg11.Attributes as A -svgHeader :: Double -> Double -> S.Svg -> S.Svg -svgHeader w h_ s = S.docTypeSvg +-- | @svgHeader w h defs s@: @w@ width, @h@ height, +-- @defs@ global definitions for defs sections, @s@ actual SVG content. +svgHeader :: Double -> Double -> Maybe S.Svg -> S.Svg -> S.Svg +svgHeader w h_ defines s = S.docTypeSvg ! A.version "1.1" ! A.width (S.toValue w) ! A.height (S.toValue h_) ! A.fontSize "1" - ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int])) $ - S.g $ s + ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int])) + $ do case defines of + Nothing -> return () + Just defs -> S.defs $ defs + S.g $ s renderPath :: Path R2 -> S.Svg renderPath (Path trs) = S.path ! A.d makePath @@ -68,22 +73,34 @@ (OffsetClosed (unr2 -> (x2,y2)))) = cr x0 y0 x1 y1 x2 y2 -renderClip :: Maybe [Path R2] -> Int -> S.Svg -renderClip Nothing _ = mempty -renderClip (Just pths) id_ = S.clippath ! A.id_ clipPathId $ renderClipPaths - where renderClipPaths = mapM_ renderPath pths - clipPathId = S.toValue $ "myClip" ++ show id_ +renderClip :: Path R2 -> Int -> S.Svg -> S.Svg +renderClip p id_ svg = do + S.g ! A.clipPath (S.toValue $ "url(#" ++ clipPathId id_ ++ ")") $ do + S.clippath ! A.id_ (S.toValue $ clipPathId id_) $ renderPath p + svg + where clipPathId i = "myClip" ++ show i --- FIXME take alignment into account renderText :: Text -> S.Svg -renderText (Text tr _ str) = +renderText (Text tr tAlign str) = S.text_ ! A.transform transformMatrix - ! A.dominantBaseline "middle" - ! A.textAnchor "middle" + ! A.dominantBaseline vAlign + ! A.textAnchor hAlign ! A.stroke "none" $ S.toMarkup str where + vAlign = case tAlign of + BaselineText -> "alphabetic" + BoxAlignedText _ h -> case h of -- A mere approximation + h' | h' <= 0.25 -> "text-after-edge" + h' | h' >= 0.75 -> "text-before-edge" + _ -> "middle" + hAlign = case tAlign of + BaselineText -> "start" + BoxAlignedText w _ -> case w of -- A mere approximation + w' | w' <= 0.25 -> "start" + w' | w' >= 0.75 -> "end" + _ -> "middle" t = tr `mappend` reflectionY (a,b,c,d,e,f) = getMatrix t transformMatrix = S.matrix a b c d e f @@ -116,7 +133,12 @@ , renderFontSlant , renderFontWeight , renderFontFamily + , renderMiterLimit ] + +renderMiterLimit :: Style v -> S.Attribute +renderMiterLimit s = renderAttr A.strokeMiterlimit miterLimit + where miterLimit = getLineMiterLimit <$> getAttr s renderLineColor :: Style v -> S.Attribute renderLineColor s = @@ -204,14 +226,6 @@ renderFontFamily s = renderAttr A.fontFamily fontFamily_ where fontFamily_ = getFont <$> getAttr s - -renderClipPathId :: Style v -> Int -> S.Attribute -renderClipPathId s id_ = renderAttr A.clipPath clipPathId - where - clipPathId :: Maybe String - clipPathId = case getClip <$> getAttr s of - Nothing -> Nothing - Just _ -> Just ("url(#myClip" ++ show id_ ++ ")") -- | Render a style attribute if available, empty otherwise. renderAttr :: S.ToValue s => (S.AttributeValue -> S.Attribute)