diagrams-svg 0.3.5 → 0.3.7
raw patch · 3 files changed
+130/−24 lines, 3 filesdep +mtldep ~blaze-svgdep ~cmdargsdep ~diagrams-corePVP ok
version bump matches the API change (PVP)
Dependencies added: mtl
Dependency ranges changed: blaze-svg, cmdargs, diagrams-core
API changes (from Hackage documentation)
Files
- diagrams-svg.cabal +5/−4
- src/Diagrams/Backend/SVG.hs +53/−15
- src/Graphics/Rendering/SVG.hs +72/−5
diagrams-svg.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-svg-Version: 0.3.5+Version: 0.3.7 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3@@ -31,13 +31,14 @@ , process >= 1.0 && < 1.2 , directory >= 1.0 && < 1.2 , filepath >= 1.2 && < 1.4+ , mtl >= 1 && < 3.0 , bytestring >= 0.9 && < 1.0 , vector-space >= 0.7 && < 0.9 , colour- , diagrams-core >= 0.5 && < 0.6+ , diagrams-core >= 0.5.0.1 && < 0.6 , diagrams-lib >= 0.5 && < 0.6- , blaze-svg >= 0.3- , cmdargs >= 0.6 && < 0.9+ , blaze-svg >= 0.3.3+ , cmdargs >= 0.6 && < 0.10 , split >= 0.1.2 && < 0.2 if !os(windows) cpp-options: -DCMDLINELOOP
src/Diagrams/Backend/SVG.hs view
@@ -15,9 +15,11 @@ -- from base import Data.Typeable+import Control.Monad.State -- from diagrams-lib import Diagrams.Prelude+import Diagrams.TwoD.Path (getClip) import Diagrams.TwoD.Adjust (adjustDia2D) import Diagrams.TwoD.Text @@ -35,33 +37,69 @@ deriving (Show, Typeable) +data SvgRenderState = SvgRenderState { clipPathId :: Int }++initialSvgRenderState :: SvgRenderState+initialSvgRenderState = SvgRenderState 0++-- Monad to keep track of state when rendering an SVG.+-- Currently just keeps a monotonically increasing counter+-- for assiging unique clip path ID+type SvgRenderM = State SvgRenderState S.Svg++incrementClipPath :: State SvgRenderState ()+incrementClipPath = modify (\(SvgRenderState x) -> SvgRenderState (x + 1))+ instance Monoid (Render SVG R2) where- mempty = R $ mempty- (R r1) `mappend` (R r2_) = R (r1 `mappend` r2_)+ mempty = R $ return mempty+ (R r1) `mappend` (R r2_) =+ R $ do+ svg1 <- r1+ svg2 <- r2_+ return (svg1 `mappend` svg2) +-- renders a <g> element with styles applied as attributes.+renderStyledGroup :: Style v -> (S.Svg -> S.Svg)+renderStyledGroup s = S.g ! R.renderStyles s +renderSvgWithClipping :: S.Svg -- Input SVG+ -> Style v -- Styles+ -> Int -- Clip Path ID+ -> S.Svg -- Resulting svg+renderSvgWithClipping svg s id_ = do+ R.renderClip (getClip <$> getAttr s) id_ -- Clipping if any+ svg -- The diagram+ instance Backend SVG R2 where- data Render SVG R2 = R S.Svg+ data Render SVG R2 = R SvgRenderM type Result SVG R2 = S.Svg data Options SVG R2 = SVGOptions { fileName :: String -- ^ the name of the file you want generated , size :: SizeSpec2D -- ^ The requested size. } - -- FIXME implement- withStyle _ s _ (R r) = R styledSvg- where styledSvg = S.g ! R.renderStyles s $ r+ withStyle _ s _ (R r) =+ R $ do+ incrementClipPath+ clipPathId_ <- gets clipPathId+ svg <- r+ let styledSvg = renderStyledGroup s ! (R.renderClipPathId s clipPathId_) $ renderSvgWithClipping svg s clipPathId_+ return styledSvg doRender _ (SVGOptions _ sz) (R r) =- let (w,h) = case sz of- Width w' -> (w',w')- Height h' -> (h',h')- Dims w' h' -> (w',h')- Absolute -> (100,100)- in R.svgHeader w h $ r+ evalState svgOutput initialSvgRenderState+ where+ svgOutput = do+ svg <- r+ let (w,h) = case sz of+ Width w' -> (w',w')+ Height h' -> (h',h')+ Dims w' h' -> (w',h')+ Absolute -> (100,100)+ return $ R.svgHeader w h $ svg adjustDia c opts d = adjustDia2D size setSvgSize c opts (d # reflectY- # fcA transparent+ # fcA transparent ) where setSvgSize sz o = o { size = sz } @@ -72,9 +110,9 @@ render c t = render c $ Path [(p2 (0,0), t)] instance Renderable (Path R2) SVG where- render _ = R . R.renderPath+ render _ = R . return . R.renderPath instance Renderable Text SVG where- render _ = R . R.renderText+ render _ = R . return . R.renderText -- TODO: instance Renderable Image SVG where
src/Graphics/Rendering/SVG.hs view
@@ -2,6 +2,8 @@ module Graphics.Rendering.SVG ( svgHeader , renderPath+ , renderClip+ , renderClipPathId , renderText , renderStyles ) where@@ -12,7 +14,7 @@ -- from diagrams-lib import Diagrams.Prelude hiding (Render, Attribute, close, e, (<>)) import Diagrams.TwoD.Text-import Diagrams.TwoD.Path (getFillRule)+import Diagrams.TwoD.Path (getFillRule, getClip) import Text.Blaze.Svg11 ((!), mkPath, m, cr, hr, vr, lr, z) import qualified Text.Blaze.Svg11 as S@@ -21,8 +23,9 @@ svgHeader :: Double -> Double -> S.Svg -> S.Svg svgHeader w h_ s = S.docTypeSvg ! A.version "1.1"- ! A.width (S.toValue w)- ! A.height (S.toValue h_)+ ! 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 @@ -43,10 +46,34 @@ 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 --- FIXME implement++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_++-- FIXME take alignment into account renderText :: Text -> S.Svg-renderText _ = mempty+renderText (Text tr _ str) =+ S.text_+ ! A.transform transformMatrix+ ! A.dominantBaseline "middle"+ ! A.textAnchor "middle"+ ! A.stroke "none" $+ S.toMarkup str+ where+ t = tr `mappend` reflectionY+ (a,b,c,d,e,f) = getMatrix t+ transformMatrix = S.matrix a b c d e f +getMatrix :: Transformation R2 -> (Double, Double, Double, Double, Double, Double)+getMatrix t = (a1,a2,b1,b2,c1,c2)+ where+ (unr2 -> (a1,a2)) = apply t unitX+ (unr2 -> (b1,b2)) = apply t unitY+ (unr2 -> (c1,c2)) = transl t+ renderStyles :: forall v. Style v -> S.Attribute renderStyles s = mconcat . map ($ s) $ [ renderLineColor@@ -57,6 +84,10 @@ , renderFillRule , renderDashing , renderOpacity+ , renderFontSize+ , renderFontSlant+ , renderFontWeight+ , renderFontFamily ] renderLineColor :: Style v -> S.Attribute@@ -119,6 +150,41 @@ arr = (dashArrayToStr . getDasharray) <$> dashing_ offset = getDashoffset <$> dashing_ +renderFontSize :: Style v -> S.Attribute+renderFontSize s = renderAttr A.fontSize fontSize_+ where+ fontSize_ = ((++ "em") . show . getFontSize) <$> getAttr s++renderFontSlant :: Style v -> S.Attribute+renderFontSlant s = renderAttr A.fontStyle fontSlant_+ where+ fontSlant_ = (fontSlantAttr . getFontSlant) <$> getAttr s+ fontSlantAttr :: FontSlant -> String+ fontSlantAttr FontSlantItalic = "italic"+ fontSlantAttr FontSlantOblique = "oblique"+ fontSlantAttr FontSlantNormal = "normal"++renderFontWeight :: Style v -> S.Attribute+renderFontWeight s = renderAttr A.fontWeight fontWeight_+ where+ fontWeight_ = (fontWeightAttr . getFontWeight) <$> getAttr s+ fontWeightAttr :: FontWeight -> String+ fontWeightAttr FontWeightNormal = "normal"+ fontWeightAttr FontWeightBold = "bold"++renderFontFamily :: Style v -> S.Attribute+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) -> Maybe s@@ -141,3 +207,4 @@ colorToOpacity :: forall c . Color c => c -> Double colorToOpacity c = a where (_,_,_,a) = colorToRGBA c+