diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ -## [v1.3.1.10](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.10) (2015-11-10) +## [v1.4](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.8) (2016-02-14) -- Fix pretty printing so that it is not the default. +-- Changes for `svg-builder` +-- Deprecate `svgId` and `svgClass` + +## [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) 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.10 +Version: 1.4 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 @@ -38,10 +38,9 @@ Library Exposed-modules: Diagrams.Backend.SVG Diagrams.Backend.SVG.CmdLine - Diagrams.Backend.SVG.Attributes Other-modules: Graphics.Rendering.SVG Hs-source-dirs: src - Build-depends: base >= 4.3 && < 4.9 + Build-depends: base >= 4.3 && < 4.10 , old-time , process , directory @@ -53,7 +52,7 @@ , diagrams-core >= 1.3 && < 1.4 , diagrams-lib >= 1.3 && < 1.4 , monoid-extras >= 0.3 && < 0.5 - , lucid-svg >= 0.5 && < 0.7 + , svg-builder >= 0.1 && < 0.2 , 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 #-} @@ -56,44 +58,48 @@ -- type of option records and rendering results specific to any -- particular backend. For @b ~ SVG@, @v ~ V2@, we have -- --- > data Options SVG V2 n = SVGOptions --- > { _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 --- > } +-- >data Options SVG V2 n = SVGOptions +-- > { _size :: SizeSpec V2 n -- ^ The requested size. +-- > , _svgDefinitions :: Maybe Element +-- > -- ^ Custom definitions that will be added to the @defs@ +-- > -- section of the output. +-- > , _idPrefix :: T.Text +-- > , _svgAttributes :: [Attribute] +-- > -- ^ Attriubtes to apply to the entire svg element. +-- > , _generateDoctype :: Bool +-- > } -- -- @ -- data family Render SVG V2 n = R 'SvgRenderM n' -- @ -- -- @ --- type family Result SVG V2 n = 'Graphics.Rendering.SVG.SvgM' +-- type family Result SVG V2 n = 'Element' -- @ -- -- So the type of 'renderDia' resolves to -- -- @ --- renderDia :: SVG -> Options SVG V2 n -> QDiagram SVG V2 n m -> 'Graphics.Rendering.SVG.SvgM' +-- renderDia :: SVG -> Options SVG V2 n -> QDiagram SVG V2 n m -> 'Graphics.Rendering.SVG.Element' -- @ -- -- which you could call like @renderDia SVG (SVGOptions (mkWidth 250) --- Nothing "") myDiagram@ (if you have the 'OverloadedStrings' extension +-- Nothing "" [] True) myDiagram@ (if you have the 'OverloadedStrings' extension -- enabled; otherwise you can use 'Text.pack ""'). (In some -- situations GHC may not be able to infer the type @m@, in which case -- you can use a type annotation to specify it; it may be useful to -- simply use the type synonym @Diagram SVG = QDiagram SVG V2 Double --- Any@.) This returns an 'Graphics.Rendering.SVG.SvgM' value, which +-- Any@.) This returns an 'Graphics.Rendering.SVG.Element' value, which -- you can, /e.g./ render to a 'ByteString' using 'Lucid.Svg.renderBS' --- from the 'lucid' package. +-- from the 'lucid-svg' package. -- ----------------------------------------------------------------------------- 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 @@ -142,11 +148,11 @@ import Diagrams.TwoD.Path (Clip (Clip)) import Diagrams.TwoD.Text --- from lucid-svg -import Lucid.Svg +-- from svg-builder +import Graphics.Svg hiding ((<>)) -- from this package -import Graphics.Rendering.SVG (SVGFloat, SvgM) +import Graphics.Rendering.SVG (SVGFloat) import qualified Graphics.Rendering.SVG as R -- | @SVG@ is simply a token used to identify this rendering backend @@ -182,9 +188,9 @@ initialSvgRenderState = SvgRenderState 0 0 1 -- | Monad to keep track of environment and state when rendering an SVG. -type SvgRenderM n = ReaderT (Environment n) (State SvgRenderState) SvgM +type SvgRenderM n = ReaderT (Environment n) (State SvgRenderState) Element -runRenderM :: SVGFloat n => T.Text -> SvgRenderM n -> SvgM +runRenderM :: SVGFloat n => T.Text -> SvgRenderM n -> Element runRenderM o s = flip evalState initialSvgRenderState $ runReaderT s (initialEnvironment o) @@ -199,7 +205,7 @@ -- renderSvgWithClipping :: forall n. SVGFloat n => T.Text - -> SvgM -- ^ Input SVG + -> Element -- ^ Input SVG -> Style V2 n -- ^ Styles -> SvgRenderM n -- ^ Resulting svg @@ -231,31 +237,38 @@ instance SVGFloat n => Backend SVG V2 n where newtype Render SVG V2 n = R (SvgRenderM n) - type Result SVG V2 n = SvgM + type Result SVG V2 n = Element 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 Element -- ^ 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) + adjustDia c opts d = ( sz, t <> reflectionY, d' ) where + (sz, t, d') = adjustDia2D sizeSpec c opts (d # reflectY) rtree :: SVGFloat n => RTree SVG V2 n Annotation -> Render SVG V2 n rtree (Node n rs) = case n of RPrim p -> render SVG p RStyle sty -> R $ local (over style (<> sty)) r - RAnnot (OpacityGroup o) -> R $ g_ [opacity_ $ toText o] <$> r - RAnnot (Href uri) -> R $ a_ [xlinkHref_ $ T.pack uri] <$> r + RAnnot (OpacityGroup o) -> R $ g_ [Opacity_ <<- toText o] <$> r + RAnnot (Href uri) -> R $ a_ [XlinkHref_ <<- T.pack uri] <$> r _ -> R r where R r = foldMap rtree rs @@ -265,7 +278,7 @@ sizeSpec f opts = f (_size opts) <&> \s -> opts { _size = s } -- | Lens onto the svg definitions of the svg options. -svgDefinitions :: SVGFloat n => Lens' (Options SVG V2 n) (Maybe SvgM) +svgDefinitions :: SVGFloat n => Lens' (Options SVG V2 n) (Maybe Element) svgDefinitions f opts = f (_svgDefinitions opts) <&> \ds -> opts { _svgDefinitions = ds } @@ -275,9 +288,21 @@ 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 +attributedRender :: SVGFloat n => Element -> SvgRenderM n attributedRender svg = do SvgRenderState _idClip idFill idLine <- get Environment sty preT <- ask @@ -285,8 +310,8 @@ lineGradDefs <- lineTextureDefs sty fillGradDefs <- fillTextureDefs sty return $ do - defs_ $ fillGradDefs >> lineGradDefs - g_ (R.renderStyles idFill idLine sty) clippedSvg + let gDefs = mappend fillGradDefs lineGradDefs + gDefs `mappend` g_ (R.renderStyles idFill idLine sty) clippedSvg instance SVGFloat n => Renderable (Path V2 n) SVG where render _ = R . attributedRender . R.renderPath @@ -300,11 +325,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 +359,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 +380,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/Attributes.hs b/src/Diagrams/Backend/SVG/Attributes.hs deleted file mode 100644 --- a/src/Diagrams/Backend/SVG/Attributes.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Backend.SVG.Attributes --- Copyright : (c) 2015 Diagrams team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Attributes that are specific to the SVG backend. The intent --- of this module is to allow adding the attributes class, --- and id attributes to an SVG. For those embedding --- the resulting SVG into a webpage, this allows some --- interactivity with javascript and stylesheets. --- ------------------------------------------------------------------------------ - -module Diagrams.Backend.SVG.Attributes ( - -- * Id - SvgId(..) - , svgId - - -- * Class - , SvgClass(..) - , svgClass - - ) where - -import Diagrams.Core.Style (AttributeClass, HasStyle, applyAttr) -import Data.Semigroup -import Data.Typeable (Typeable) - ------------------------------------------------------------------ --- Id ------------------------------------------------------------------ - --- | The SVG id attribute. -newtype SvgId = SvgId {getSvgId :: String} - deriving Typeable - -instance Semigroup SvgId where - _ <> a = a -instance AttributeClass SvgId - --- | Set the Id attribute. -svgId :: HasStyle a => String -> a -> a -svgId = applyAttr . SvgId - ------------------------------------------------------------------ --- Class ------------------------------------------------------------------ - --- | The SVG class attribute. -newtype SvgClass = SvgClass {getSvgClass :: String} - deriving Typeable - -instance Semigroup SvgClass where - _ <> a = a - -instance AttributeClass SvgClass - --- | Set the class attribute. -svgClass :: HasStyle a => String -> a -> a -svgClass = applyAttr . SvgClass 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,7 +20,7 @@ module Graphics.Rendering.SVG ( SVGFloat - , SvgM + , Element , AttributeValue , svgHeader , renderPath @@ -51,8 +51,7 @@ import Diagrams.Core.Transform (matrixHomRep) -- from diagrams-lib -import Diagrams.Prelude hiding (Attribute, Render, with, - (<>)) +import Diagrams.Prelude hiding (Attribute, Render, with, (<>)) import Diagrams.TwoD.Path (getFillRule) import Diagrams.TwoD.Text @@ -61,7 +60,7 @@ import qualified Data.Text as T -- from lucid-svg -import Lucid.Svg hiding (renderText) +import Graphics.Svg hiding (renderText) -- from base64-bytestring, bytestring import qualified Data.ByteString.Base64.Lazy as BS64 @@ -70,9 +69,6 @@ -- from JuicyPixels import Codec.Picture --- from same package -import Diagrams.Backend.SVG.Attributes (SvgId(..),SvgClass(..)) - -- | Constaint on number type that diagrams-svg can use to render an SVG. This -- includes the common number types: Double, Float type SVGFloat n = (Show n, TypeableFloat n) @@ -80,9 +76,6 @@ -- showFFloat :: RealFloat a => Maybe Int -> a -> ShowS -- or something similar for all numbers so we need TypeableFloat constraint. --- | The Svg monad, synonym for @HtmlT m ()@ Lucid.Base. -type SvgM = Svg () - type AttributeValue = T.Text getNumAttr :: AttributeClass (a n) => (a n -> t) -> Style v n -> Maybe t @@ -90,24 +83,29 @@ -- | @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 Element -> [Attribute] -> Bool + -> Element -> Element +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] +renderPath :: SVGFloat n => Path V2 n -> Element +renderPath trs = if makePath == T.empty then mempty else path_ [D_ <<- makePath] where makePath = foldMap renderTrail (op Path trs) renderTrail :: SVGFloat n => Located (Trail V2 n) -> AttributeValue -renderTrail (viewLoc -> (P (V2 x y), t)) = mA x y <> withTrail renderLine renderLoop t +renderTrail (viewLoc -> (P (V2 x y), t)) = + mA x y <> withTrail renderLine renderLoop t where renderLine = foldMap renderSeg . lineSegments renderLoop lp = @@ -127,34 +125,34 @@ (V2 x1 y1) (OffsetClosed (V2 x2 y2))) = cR x0 y0 x1 y1 x2 y2 -renderClip :: SVGFloat n => Path V2 n -> T.Text -> Int -> SvgM -> SvgM +renderClip :: SVGFloat n => Path V2 n -> T.Text -> Int -> Element -> Element renderClip p prefix ident svg = do - defs_ $ clipPath_ [id_ (clipPathId ident)] (renderPath p) - g_ [clip_path_ $ ("url(#" <> clipPathId ident <> ")")] svg + defs_ [] $ clipPath_ [Id_ <<- (clipPathId ident)] (renderPath p) + <> g_ [Clip_path_ <<- ("url(#" <> clipPathId ident <> ")")] svg where clipPathId i = prefix <> "myClip" <> (pack . show $ i) -renderStop :: SVGFloat n => GradientStop n -> SvgM +renderStop :: SVGFloat n => GradientStop n -> Element renderStop (GradientStop c v) - = stop_ [ stop_color_ (colorToRgbText c) - , offset_ (toText v) - , stop_opacity_ (toText $ colorToOpacity c) ] + = stop_ [ Stop_color_ <<- (colorToRgbText c) + , Offset_ <<- (toText v) + , Stop_opacity_ <<- (toText $ colorToOpacity c) ] spreadMethodText :: SpreadMethod -> AttributeValue spreadMethodText GradPad = "pad" spreadMethodText GradReflect = "reflect" spreadMethodText GradRepeat = "repeat" -renderLinearGradient :: SVGFloat n => LGradient n -> Int -> SvgM +renderLinearGradient :: SVGFloat n => LGradient n -> Int -> Element renderLinearGradient g i = linearGradient_ - [ id_ (pack $ "gradient" ++ show i) - , x1_ (toText x1) - , y1_ (toText y1) - , x2_ (toText x2) - , y2_ (toText y2) - , gradientTransform_ mx - , gradientUnits_ "userSpaceOnUse" - , spreadMethod_ (spreadMethodText (g ^. lGradSpreadMethod)) ] + [ Id_ <<- (pack $ "gradient" ++ show i) + , X1_ <<- toText x1 + , Y1_ <<- toText y1 + , X2_ <<- toText x2 + , Y2_ <<- toText y2 + , GradientTransform_ <<- mx + , GradientUnits_ <<- "userSpaceOnUse" + , SpreadMethod_ <<- spreadMethodText (g ^. lGradSpreadMethod) ] $ foldMap renderStop (g^.lGradStops) where mx = matrix a1 a2 b1 b2 c1 c2 @@ -162,17 +160,17 @@ P (V2 x1 y1) = g ^. lGradStart P (V2 x2 y2) = g ^. lGradEnd -renderRadialGradient :: SVGFloat n => RGradient n -> Int -> SvgM +renderRadialGradient :: SVGFloat n => RGradient n -> Int -> Element renderRadialGradient g i = radialGradient_ - [ id_ (pack $ "gradient" ++ show i) - , r_ (toText (g ^. rGradRadius1)) - , cx_ (toText cx) - , cy_ (toText cy) - , fx_ (toText fx) - , fy_ (toText fy) - , gradientTransform_ mx - , gradientUnits_ "userSpaceOnUse" - , spreadMethod_ (spreadMethodText (g ^. rGradSpreadMethod)) ] + [ Id_ <<- (pack $ "gradient" ++ show i) + , R_ <<- toText (g ^. rGradRadius1) + , Cx_ <<- toText cx + , Cy_ <<- toText cy + , Fx_ <<- toText fx + , Fy_ <<- toText fy + , GradientTransform_ <<- mx + , GradientUnits_ <<- "userSpaceOnUse" + , SpreadMethod_ <<- spreadMethodText (g ^. rGradSpreadMethod) ] ( foldMap renderStop ss ) where mx = matrix a1 a2 b1 b2 c1 c2 @@ -192,51 +190,51 @@ ss = zipWith (\gs sf -> gs & stopFraction .~ sf ) gradStops stopFracs -- Create a gradient element so that it can be used as an attribute value for fill. -renderFillTextureDefs :: SVGFloat n => Int -> Style v n -> SvgM +renderFillTextureDefs :: SVGFloat n => Int -> Style v n -> Element renderFillTextureDefs i s = case getNumAttr getFillTexture s of - Just (LG g) -> renderLinearGradient g i - Just (RG g) -> renderRadialGradient g i + Just (LG g) -> defs_ [] $ renderLinearGradient g i + Just (RG g) -> defs_ [] $ renderRadialGradient g i _ -> mempty -- Render the gradient using the id set up in renderFillTextureDefs. renderFillTexture :: SVGFloat n => Int -> Style v n -> [Attribute] renderFillTexture ident s = case getNumAttr getFillTexture s of - Just (SC (SomeColor c)) -> renderTextAttr fill_ fillColorRgb <> - renderAttr fill_opacity_ fillColorOpacity + Just (SC (SomeColor c)) -> renderTextAttr Fill_ fillColorRgb <> + renderAttr Fill_opacity_ fillColorOpacity where fillColorRgb = Just $ colorToRgbText c fillColorOpacity = Just $ colorToOpacity c - Just (LG _) -> [fill_ ("url(#gradient" <> (pack . show $ ident) - <> ")"), fill_opacity_ "1"] - Just (RG _) -> [fill_ ("url(#gradient" <> (pack . show $ ident) - <> ")"), fill_opacity_ "1"] + Just (LG _) -> [Fill_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Fill_opacity_ <<- "1"] + Just (RG _) -> [Fill_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Fill_opacity_ <<- "1"] Nothing -> [] -renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> SvgM +renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> Element renderLineTextureDefs i s = case getNumAttr getLineTexture s of - Just (LG g) -> renderLinearGradient g i - Just (RG g) -> renderRadialGradient g i + Just (LG g) -> defs_ [] $ renderLinearGradient g i + Just (RG g) -> defs_ [] $ renderRadialGradient g i _ -> mempty renderLineTexture :: SVGFloat n => Int -> Style v n -> [Attribute] renderLineTexture ident s = case getNumAttr getLineTexture s of - Just (SC (SomeColor c)) -> renderTextAttr stroke_ lineColorRgb <> - renderAttr stroke_opacity_ lineColorOpacity + Just (SC (SomeColor c)) -> renderTextAttr Stroke_ lineColorRgb <> + renderAttr Stroke_opacity_ lineColorOpacity where lineColorRgb = Just $ colorToRgbText c lineColorOpacity = Just $ colorToOpacity c - Just (LG _) -> [stroke_ ("url(#gradient" <> (pack . show $ ident) - <> ")"), stroke_opacity_ "1"] - Just (RG _) -> [stroke_ ("url(#gradient" <> (pack . show $ ident) - <> ")"), stroke_opacity_ "1"] + Just (LG _) -> [Stroke_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Stroke_opacity_ <<- "1"] + Just (RG _) -> [Stroke_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Stroke_opacity_ <<- "1"] Nothing -> [] dataUri :: String -> BS8.ByteString -> AttributeValue dataUri mime dat = pack $ "data:"++mime++";base64," ++ BS8.unpack (BS64.encode dat) -renderDImageEmb :: SVGFloat n => DImage n Embedded -> SvgM +renderDImageEmb :: SVGFloat n => DImage n Embedded -> Element renderDImageEmb di@(DImage (ImageRaster dImg) _ _ _) = renderDImage di $ dataUri "image/png" img where @@ -244,13 +242,13 @@ Left str -> error str Right img' -> img' -renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> SvgM +renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> Element renderDImage (DImage _ w h tr) uridata = image_ - [ transform_ transformMatrix - , width_ (pack . show $ w) - , height_ (pack . show $ h) - , xlinkHref_ uridata ] + [ Transform_ <<- transformMatrix + , Width_ <<- (pack . show $ w) + , Height_ <<- (pack . show $ h) + , XlinkHref_ <<- uridata ] where [[a,b],[c,d],[e,f]] = matrixHomRep (tr `mappend` reflectionY `mappend` tX `mappend` tY) @@ -258,14 +256,14 @@ tX = translationX $ fromIntegral (-w)/2 tY = translationY $ fromIntegral (-h)/2 -renderText :: SVGFloat n => Text n -> SvgM +renderText :: SVGFloat n => Text n -> Element renderText (Text tt tAlign str) = text_ - [ transform_ transformMatrix - , dominant_baseline_ vAlign - , text_anchor_ hAlign - , stroke_ "none" ] - $ toHtml str + [ Transform_ <<- transformMatrix + , Dominant_baseline_ <<- vAlign + , Text_anchor_ <<- hAlign + , Stroke_ <<- "none" ] + $ toElement str where vAlign = case tAlign of BaselineText -> "alphabetic" @@ -297,40 +295,29 @@ , renderFontSlant , renderFontWeight , renderFontFamily - , renderSvgId - , renderSvgClass , renderMiterLimit ] - -renderSvgId :: SVGFloat n => Style v n -> [Attribute] -renderSvgId s = renderTextAttr id_ svgIdAttr - where svgIdAttr = pack . getSvgId <$> getAttr s - -renderSvgClass :: SVGFloat n => Style v n -> [Attribute] -renderSvgClass s = renderTextAttr class_ svgClassAttr - where svgClassAttr = pack . getSvgClass <$> getAttr s - renderMiterLimit :: SVGFloat n => Style v n -> [Attribute] -renderMiterLimit s = renderAttr stroke_miterlimit_ miterLimit +renderMiterLimit s = renderAttr Stroke_miterlimit_ miterLimit where miterLimit = getLineMiterLimit <$> getAttr s renderOpacity :: SVGFloat n => Style v n -> [Attribute] -renderOpacity s = renderAttr opacity_ o +renderOpacity s = renderAttr Opacity_ o where o = getOpacity <$> getAttr s renderFillRule :: SVGFloat n => Style v n -> [Attribute] -renderFillRule s = renderTextAttr fill_rule_ fr +renderFillRule s = renderTextAttr Fill_rule_ fr where fr = (fillRuleToText . getFillRule) <$> getAttr s fillRuleToText :: FillRule -> AttributeValue fillRuleToText Winding = "nonzero" fillRuleToText EvenOdd = "evenodd" renderLineWidth :: SVGFloat n => Style v n -> [Attribute] -renderLineWidth s = renderAttr stroke_width_ lWidth +renderLineWidth s = renderAttr Stroke_width_ lWidth where lWidth = getNumAttr getLineWidth s renderLineCap :: SVGFloat n => Style v n -> [Attribute] -renderLineCap s = renderTextAttr stroke_linecap_ lCap +renderLineCap s = renderTextAttr Stroke_linecap_ lCap where lCap = (lineCapToText . getLineCap) <$> getAttr s lineCapToText :: LineCap -> AttributeValue lineCapToText LineCapButt = "butt" @@ -338,7 +325,7 @@ lineCapToText LineCapSquare = "square" renderLineJoin :: SVGFloat n => Style v n -> [Attribute] -renderLineJoin s = renderTextAttr stroke_linejoin_ lj +renderLineJoin s = renderTextAttr Stroke_linejoin_ lj where lj = (lineJoinToText . getLineJoin) <$> getAttr s lineJoinToText :: LineJoin -> AttributeValue lineJoinToText LineJoinMiter = "miter" @@ -346,26 +333,26 @@ lineJoinToText LineJoinBevel = "bevel" renderDashing :: SVGFloat n => Style v n -> [Attribute] -renderDashing s = renderTextAttr stroke_dasharray_ arr <> - renderAttr stroke_dashoffset_ dOffset +renderDashing s = renderTextAttr Stroke_dasharray_ arr <> + renderAttr Stroke_dashoffset_ dOffset where getDasharray (Dashing a _) = a getDashoffset (Dashing _ o) = o - dashArrayToStr = intercalate "," . map show + dashArrayToStr = intercalate "," . map show -- Ignore dashing if dashing array is empty checkEmpty (Just (Dashing [] _)) = Nothing - checkEmpty other = other - dashing' = checkEmpty $ getNumAttr getDashing s - arr = (pack . dashArrayToStr . getDasharray) <$> dashing' - dOffset = getDashoffset <$> dashing' + checkEmpty other = other + dashing' = checkEmpty $ getNumAttr getDashing s + arr = (pack . dashArrayToStr . getDasharray) <$> dashing' + dOffset = getDashoffset <$> dashing' renderFontSize :: SVGFloat n => Style v n -> [Attribute] -renderFontSize s = renderTextAttr font_size_ fs +renderFontSize s = renderTextAttr Font_size_ fs where fs = pack <$> getNumAttr ((++ "px") . show . getFontSize) s renderFontSlant :: SVGFloat n => Style v n -> [Attribute] -renderFontSlant s = renderTextAttr font_style_ fs +renderFontSlant s = renderTextAttr Font_style_ fs where fs = (fontSlantAttr . getFontSlant) <$> getAttr s fontSlantAttr :: FontSlant -> AttributeValue @@ -374,7 +361,7 @@ fontSlantAttr FontSlantNormal = "normal" renderFontWeight :: SVGFloat n => Style v n -> [Attribute] -renderFontWeight s = renderTextAttr font_weight_ fw +renderFontWeight s = renderTextAttr Font_weight_ fw where fw = (fontWeightAttr . getFontWeight) <$> getAttr s fontWeightAttr :: FontWeight -> AttributeValue @@ -382,16 +369,17 @@ fontWeightAttr FontWeightBold = "bold" renderFontFamily :: SVGFloat n => Style v n -> [Attribute] -renderFontFamily s = renderTextAttr font_family_ ff +renderFontFamily s = renderTextAttr Font_family_ ff where ff = (pack . getFont) <$> getAttr s -- | Render a style attribute if available, empty otherwise. -renderAttr :: Show s => (AttributeValue -> Attribute) -> Maybe s -> [Attribute] -renderAttr attr valM = maybe [] (\v -> [attr (pack . show $ v)]) valM +renderAttr :: Show s => AttrTag -> Maybe s -> [Attribute] +renderAttr attr valM = maybe [] (\v -> [(bindAttr attr) (pack . show $ v)]) valM -renderTextAttr :: (AttributeValue -> Attribute) -> Maybe AttributeValue -> [Attribute] -renderTextAttr attr valM = maybe [] (\v -> [attr v]) valM +-- renderTextAttr :: (AttributeValue -> Attribute) -> Maybe AttributeValue -> [Attribute] +renderTextAttr :: AttrTag -> Maybe AttributeValue -> [Attribute] +renderTextAttr attr valM = maybe [] (\v -> [(bindAttr attr) v]) valM colorToRgbText :: forall c . Color c => c -> AttributeValue colorToRgbText c = T.concat