diagrams-svg 0.3.2 → 0.3.3
raw patch · 4 files changed
+86/−25 lines, 4 filesdep −blaze-htmldep ~blaze-svgPVP ok
version bump matches the API change (PVP)
Dependencies removed: blaze-html
Dependency ranges changed: blaze-svg
API changes (from Hackage documentation)
Files
- diagrams-svg.cabal +2/−3
- src/Diagrams/Backend/SVG.hs +10/−2
- src/Diagrams/Backend/SVG/CmdLine.hs +2/−2
- src/Graphics/Rendering/SVG.hs +72/−18
diagrams-svg.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-svg-Version: 0.3.2+Version: 0.3.3 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3@@ -34,8 +34,7 @@ , colour , diagrams-core >= 0.5 && < 0.6 , diagrams-lib >= 0.5 && < 0.6- , blaze-svg >= 0.1- , blaze-html >= 0.4 && < 0.5+ , blaze-svg >= 0.2 , cmdargs >= 0.6 && < 0.9 , split >= 0.1.2 && < 0.2 if !os(windows)
src/Diagrams/Backend/SVG.hs view
@@ -23,7 +23,11 @@ -- from blaze-svg import qualified Text.Blaze.Svg11 as S+import Text.Blaze.Svg11 ((!)) +-- from colour+import Data.Colour (transparent)+ -- from this package import qualified Graphics.Rendering.SVG as R @@ -44,7 +48,9 @@ , size :: SizeSpec2D -- ^ The requested size. } - withStyle _ _ _ d = d+ -- FIXME implement+ withStyle _ s _ (R r) = R styledSvg+ where styledSvg = S.g ! R.renderStyles s $ r doRender _ (SVGOptions _ sz) (R r) = let (w,h) = case sz of@@ -54,7 +60,9 @@ Absolute -> (100,100) in R.svgHeader w h $ r - adjustDia c opts d = adjustDia2D size setSvgSize c opts d+ adjustDia c opts d = adjustDia2D size setSvgSize c opts (d # reflectY+ # fcA transparent+ ) where setSvgSize sz o = o { size = sz } instance Renderable (Segment R2) SVG where
src/Diagrams/Backend/SVG/CmdLine.hs view
@@ -21,7 +21,7 @@ import System.Console.CmdArgs.Implicit hiding (args) -import Text.Blaze.Renderer.Utf8 (renderHtml)+import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) import qualified Data.ByteString.Lazy as BS import Prelude hiding (catch)@@ -110,7 +110,7 @@ (fromIntegral h) build = renderDia SVG (SVGOptions (output opts) sizeSpec) d- BS.writeFile (output opts) (renderHtml build)+ BS.writeFile (output opts) (renderSvg build) | otherwise -> putStrLn $ "Unknown file type: " ++ last ps multiMain :: [(String, Diagram SVG R2)] -> IO ()
src/Graphics/Rendering/SVG.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ViewPatterns, OverloadedStrings, RankNTypes #-} module Graphics.Rendering.SVG ( svgHeader , renderPath , renderText+ , renderStyles ) where -- from base@@ -22,23 +23,7 @@ ! A.width (S.toValue w) ! A.height (S.toValue h_) ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int])) $- topLevelGroup $ s--topLevelGroup :: S.Svg -> S.Svg-topLevelGroup = S.g- ! A.fill "rgb(0,0,0)"- ! A.fillOpacity "0"- ! A.fillRule "nonzero"- ! A.fontFamily "Sans"- ! A.fontSize "1"- ! A.fontStyle "normal"- ! A.opacity "1"- ! A.stroke "rgb(0,0,0)"- ! A.strokeOpacity "1"- ! A.strokeWidth "0.5"- ! A.strokeLinecap "butt"- ! A.strokeLinejoin "miter"- ! A.textAnchor "middle"+ S.g $ s renderPath :: Path R2 -> S.Svg renderPath (Path trs) = S.path ! A.d makePath@@ -60,3 +45,72 @@ -- FIXME implement renderText :: Text -> S.Svg renderText _ = mempty++renderStyles :: forall v. Style v -> S.Attribute+renderStyles s = mconcat . map ($ s) $+ [ renderLineColor+ , renderFillColor+ , renderLineWidth+ , renderLineCap+ , renderLineJoin+ ]++renderLineColor :: Style v -> S.Attribute+renderLineColor s =+ (renderAttr A.stroke lineColorRgb) `mappend`+ (renderAttr A.strokeOpacity lineColorOpacity)+ where lineColor_ = getLineColor `fmap` getAttr s+ lineColorRgb = colorToRgbString `fmap` lineColor_+ lineColorOpacity = colorToOpacity `fmap` lineColor_++renderFillColor :: Style v -> S.Attribute+renderFillColor s =+ (renderAttr A.fill fillColorRgb) `mappend`+ (renderAttr A.fillOpacity fillColorOpacity)+ where fillColor_ = getFillColor `fmap` getAttr s+ fillColorRgb = colorToRgbString `fmap` fillColor_+ fillColorOpacity = colorToOpacity `fmap` fillColor_+++renderLineWidth :: Style v -> S.Attribute+renderLineWidth s = renderAttr A.strokeWidth lineWidth_+ where lineWidth_ = getLineWidth `fmap` getAttr s++renderLineCap :: Style v -> S.Attribute+renderLineCap s = renderAttr A.strokeLinecap lineCap_+ where lineCap_ = (lineCapToStr . getLineCap) `fmap` getAttr s+ lineCapToStr :: LineCap -> String+ lineCapToStr LineCapButt = "butt"+ lineCapToStr LineCapRound = "round"+ lineCapToStr LineCapSquare = "square"++renderLineJoin :: Style v -> S.Attribute+renderLineJoin s = renderAttr A.strokeLinejoin lineJoin_+ where lineJoin_ = (lineJoinToStr . getLineJoin) `fmap` getAttr s+ lineJoinToStr :: LineJoin -> String+ lineJoinToStr LineJoinMiter = "miter"+ lineJoinToStr LineJoinRound = "round"+ lineJoinToStr LineJoinBevel = "bevel"++-- Render a style attribute if available, empty otherwise+renderAttr :: S.ToValue s => (S.AttributeValue -> S.Attribute)+ -> Maybe s+ -> S.Attribute+renderAttr attr valM = case valM of+ Just val -> attr (S.toValue val)+ Nothing -> mempty++colorToRgbString :: forall c . Color c => c -> String+colorToRgbString c = concat+ [ "rgb("+ , int r, ","+ , int g, ","+ , int b+ , ")"+ ]+ where int d = show (round (d * 255) :: Int)+ (r,g,b,_) = colorToRGBA c++colorToOpacity :: forall c . Color c => c -> Double+colorToOpacity c = a+ where (_,_,_,a) = colorToRGBA c