diagrams-svg 0.7 → 0.8
raw patch · 5 files changed
+88/−39 lines, 5 files
Files
- CHANGES.markdown +14/−0
- diagrams-svg.cabal +1/−1
- src/Diagrams/Backend/SVG.hs +35/−14
- src/Diagrams/Backend/SVG/CmdLine.hs +1/−1
- src/Graphics/Rendering/SVG.hs +37/−23
CHANGES.markdown view
@@ -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 ------------------
diagrams-svg.cabal view
@@ -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
src/Diagrams/Backend/SVG.hs view
@@ -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)
src/Diagrams/Backend/SVG/CmdLine.hs view
@@ -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
src/Graphics/Rendering/SVG.hs view
@@ -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)