diagrams-svg-0.8.0.2/0000755000000000000000000000000012233035572012433 5ustar0000000000000000diagrams-svg-0.8.0.2/Setup.hs0000644000000000000000000000011012233035572014057 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain diagrams-svg-0.8.0.2/CHANGES.markdown0000644000000000000000000000214512233035572015251 0ustar00000000000000000.8.0.2 (26 October 2013) ------------------------- - Documentation improvements 0.8.0.1: 11 September 2013 -------------------------- - require diagrams-lib-0.7.1 0.8: 10 September 2013 [BROKEN] ------------------------------- * **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 ------------------ * **New features** - New `renderToSVG` convenience function - Vastly improved Haddock documentation * **New instances** - `Show` instance for `Options SVG R2` * **Dependency/version changes** - allow `base-4.7` and `unix-2.7` - Upgrade to `monoid-extras-0.3` 0.6.0.1: 14 December 2012 ------------------------- * Fix link to README on Hackage page 0.6: 11 December 2012 --------------------- First "officially supported" release. Features still not implemented: - text alignment - inline images As of this release everything else Should Work (tm). diagrams-svg-0.8.0.2/LICENSE0000644000000000000000000000341712233035572013445 0ustar0000000000000000Copyright 2011-2013 diagrams-svg team: Deepak Jois Felipe Lessa Chris Mears Michael Sloan Michael Thompson Ryan Yates Brent Yorgey All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Ryan Yates nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diagrams-svg-0.8.0.2/README.md0000644000000000000000000000421112233035572013710 0ustar0000000000000000[![Build Status](https://secure.travis-ci.org/diagrams/diagrams-svg.png)](http://travis-ci.org/diagrams/diagrams-svg) _diagrams-svg_ is a an SVG backend for [diagrams]. Diagrams is a powerful, flexible, declarative domain-specific language for creating vector graphics, using the [Haskell programming language][haskell]. [diagrams]: http://projects.haskell.org/diagrams/ [haskell]: http://www.haskell.org/haskellwiki/Haskell _diagrams-svg_ is the default out-of-the box backend that comes with the diagrams framework, and supports most features defined in [diagrams-lib]. [diagrams-lib]: http://hackage.haskell.org/package/diagrams%2Dlib # Installation ``` cabal update && cabal install diagrams-svg ``` # Usage A simple example that uses _diagrams-svg_ to draw a square. ```haskell import Diagrams.Prelude import Diagrams.Backend.SVG.CmdLine b1 = square 20 # lw 0.002 main = defaultMain (pad 1.1 b1) ``` Save this to file named `Square.hs` and compile this program: ``` ghc --make Square.hs ``` This will generate an executable which, when run produces an SVG file. Run the executable with the `--help` option to find out more about how to call it. ``` $ ./Square --help Command-line diagram generation. Square [OPTIONS] Common flags: -w --width=INT Desired width of the output image -h --height=INT Desired height of the output image -o --output=FILE Output file -? --help Display help message -V --version Print version information ``` You _must_ pass an output file name with a `.svg` extension to generate the SVG file. ``` $ ./Square -o square.svg ``` The command above generates the SVG file: ``` ``` diagrams-svg-0.8.0.2/diagrams-svg.cabal0000644000000000000000000000533512233035572016011 0ustar0000000000000000Name: diagrams-svg Version: 0.8.0.2 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 License-file: LICENSE Extra-source-files: README.md, CHANGES.markdown Author: Felipe Lessa, Deepak Jois Maintainer: diagrams-discuss@googlegroups.com Bug-reports: http://github.com/diagrams/diagrams-svg/issues Stability: Experimental Category: Graphics Build-type: Simple Cabal-version: >=1.10 Tested-with: GHC == 7.4.2, GHC == 7.6.1 Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL to SVG files. It uses @blaze-svg@ to be a fast, native Haskell backend, making it suitable for use on any platform. . The package provides the following modules: . * "Diagrams.Backend.SVG.CmdLine" - if you're just getting started with diagrams, begin here. . * "Diagrams.Backend.SVG" - look at this next. The general API for the SVG backend. . Additional documentation can be found in the README file distributed with the source tarball or viewable on GitHub: . Source-repository head type: git location: http://github.com/diagrams/diagrams-svg Library Exposed-modules: Diagrams.Backend.SVG Diagrams.Backend.SVG.CmdLine Other-modules: Graphics.Rendering.SVG Hs-source-dirs: src Build-depends: base >= 4.3 && < 4.8 , old-time , process , directory , filepath , mtl >= 1 && < 2.2 , bytestring >= 0.9 && < 1.0 , vector-space >= 0.7 && < 0.9 , colour , diagrams-core >= 0.7 && < 0.8 , diagrams-lib >= 0.7.1 && < 0.8 , monoid-extras >= 0.3 && < 0.4 , blaze-svg >= 0.3.3 , cmdargs >= 0.6 && < 0.11 , split >= 0.1.2 && < 0.3 , time if !os(windows) cpp-options: -DCMDLINELOOP Build-depends: unix >= 2.4 && < 2.8 Ghc-options: -Wall Default-language: Haskell2010 diagrams-svg-0.8.0.2/src/0000755000000000000000000000000012233035572013222 5ustar0000000000000000diagrams-svg-0.8.0.2/src/Diagrams/0000755000000000000000000000000012233035572014751 5ustar0000000000000000diagrams-svg-0.8.0.2/src/Diagrams/Backend/0000755000000000000000000000000012233035572016300 5ustar0000000000000000diagrams-svg-0.8.0.2/src/Diagrams/Backend/SVG.hs0000644000000000000000000002254012233035572017276 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.SVG -- Copyright : (c) 2011-2012 diagrams-svg team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A full-featured rendering backend for diagrams producing SVG files, -- implemented natively in Haskell (making it easy to use on any -- platform). -- -- To invoke the SVG backend, you have three options. -- -- * You can use the "Diagrams.Backend.SVG.CmdLine" module to create -- standalone executables which output SVG images when invoked. -- -- * You can use the 'renderSVG' function provided by this module, -- which gives you more flexible programmatic control over when and -- how images are output (making it easy to, for example, write a -- single program that outputs multiple images, or one that outputs -- images dynamically based on user input, and so on). -- -- * For the most flexibility (/e.g./ if you want access to the -- resulting SVG value directly in memory without writing it to -- disk), you can manually invoke the 'renderDia' method from the -- 'Diagrams.Core.Types.Backend' instance for @SVG@. In particular, -- 'Diagrams.Core.Types.renderDia' has the generic type -- -- > renderDia :: b -> Options b v -> QDiagram b v m -> Result b v -- -- (omitting a few type class constraints). @b@ represents the -- backend type, @v@ the vector space, and @m@ the type of monoidal -- query annotations on the diagram. 'Options' and 'Result' are -- associated data and type families, respectively, which yield the -- type of option records and rendering results specific to any -- particular backend. For @b ~ SVG@ and @v ~ R2@, we have -- -- > 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. -- > } -- -- @ -- data family Render SVG R2 = R 'SvgRenderM' -- @ -- -- @ -- type family Result SVG R2 = 'Text.Blaze.Svg11.Svg' -- @ -- -- So the type of 'renderDia' resolves to -- -- @ -- renderDia :: SVG -> Options SVG R2 -> QDiagram SVG R2 m -> 'Text.Blaze.Svg11.Svg' -- @ -- -- which you could call like @renderDia SVG (SVGOptions (Width 250)) -- myDiagram@. (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 -- R2 = QDiagram SVG R2 Any@.) This returns an -- 'Text.Blaze.Svg11.Svg' value, which you can, /e.g./ render to a -- 'ByteString' using 'Text.Blaze.Svg.Renderer.Utf8.renderSvg'. -- ----------------------------------------------------------------------------- module Diagrams.Backend.SVG ( SVG(..) -- rendering token , Options(..) -- for rendering options specific to SVG , renderSVG ) where -- from base import Control.Monad.State import Data.Typeable -- from bytestring import qualified Data.ByteString.Lazy as BS -- from diagrams-lib import Diagrams.Prelude import Diagrams.TwoD.Adjust (adjustDia2D) import Diagrams.TwoD.Path (getClip) import Diagrams.TwoD.Text -- from monoid-extras import Data.Monoid.Split (Split (..)) -- from blaze-svg 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 -- | @SVG@ is simply a token used to identify this rendering backend -- (to aid type inference). data SVG = SVG deriving (Show, Typeable) data SvgRenderState = SvgRenderState { clipPathId :: Int, ignoreFill :: Bool } initialSvgRenderState :: SvgRenderState initialSvgRenderState = SvgRenderState 0 False -- | Monad to keep track of state when rendering an SVG. -- Currently just keeps a monotonically increasing counter -- for assiging a unique clip path ID. type SvgRenderM = State SvgRenderState S.Svg incrementClipPath :: State SvgRenderState () incrementClipPath = modify (\st -> st { clipPathId = clipPathId st + 1 }) setIgnoreFill :: Bool -> State SvgRenderState () setIgnoreFill b = modify (\st -> st { ignoreFill = b }) instance Monoid (Render SVG R2) where mempty = R $ return mempty (R r1) `mappend` (R r2_) = R $ do svg1 <- r1 svg2 <- r2_ return (svg1 `mappend` svg2) -- | Renders a element with styles applied as attributes. renderStyledGroup :: Bool -> Style v -> (S.Svg -> S.Svg) renderStyledGroup ignFill s = S.g ! R.renderStyles ignFill s renderSvgWithClipping :: S.Svg -- ^ Input SVG -> Style v -- ^ Styles -> Transformation R2 -- ^ Freeze transform -> 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. } -- | Here the SVG backend is different from the other backends. We -- give a different definition of renderDia, where only the -- non-frozen transformation is applied to the primitives before -- they are passed to render. This means that withStyle is -- responsible for applying the frozen transformation to the -- primitives. withStyle _ s t (R r) = R $ do setIgnoreFill False svg <- r ign <- gets ignoreFill 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 _ opts (R r) = evalState svgOutput initialSvgRenderState where svgOutput = do svg <- r 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 (svgDefinitions opts) $ svg adjustDia c opts d = adjustDia2D size setSvgSize c opts (d # reflectY # recommendFillColor (transparent :: AlphaColour Double) ) where setSvgSize sz o = o { size = sz } -- | This implementation of renderDia is the same as the default one, -- except that it only applies the non-frozen transformation to the -- primitives before passing them to render. renderDia SVG opts d = doRender SVG opts' . mconcat . map renderOne . prims $ d' where (opts', d') = adjustDia SVG opts d renderOne :: (Prim SVG R2, (Split (Transformation R2), Style R2)) -> Render SVG R2 renderOne (p, (M t, s)) = withStyle SVG s mempty (render SVG (transform t p)) renderOne (p, (t1 :| t2, s)) -- Here is the difference from the default -- 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) . (:[]) instance Renderable (Trail R2) SVG where render c = render c . pathFromTrail instance Renderable (Path R2) SVG where render _ p = R $ do -- Don't fill lines. diagrams-lib separates out lines and loops -- for us, so if we see one line, they are all lines. when (any (isLine . unLoc) . pathTrails $ p) $ setIgnoreFill True return (R.renderPath p) instance Renderable Text SVG where render _ = R . return . R.renderText -- TODO: instance Renderable Image SVG where -- | Render a diagram as an SVG, writing to the specified output file -- and using the requested size. renderSVG :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO () renderSVG outFile sizeSpec = BS.writeFile outFile . renderSvg . renderDia SVG (SVGOptions sizeSpec Nothing) diagrams-svg-0.8.0.2/src/Diagrams/Backend/SVG/0000755000000000000000000000000012233035572016737 5ustar0000000000000000diagrams-svg-0.8.0.2/src/Diagrams/Backend/SVG/CmdLine.hs0000644000000000000000000001777612233035572020630 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.SVG.CmdLine -- Copyright : (c) 2011 Diagrams team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Convenient creation of command-line-driven executables for -- rendering diagrams using the SVG backend. -- -- * 'defaultMain' creates an executable which can render a single -- diagram at various options. -- -- * 'multiMain' is like 'defaultMain' but allows for a list of -- diagrams from which the user can choose one to render. -- -- If you want to generate diagrams programmatically---/i.e./ if you -- want to do anything more complex than what the below functions -- provide---you have several options. -- -- * A simple but somewhat inflexible approach is to wrap up -- 'defaultMain' (or 'multiMain') in a call to -- 'System.Environment.withArgs'. -- -- * You can use 'Diagrams.Backend.SVG.renderSVG' to render a diagram -- to a file directly; see "Diagrams.Backend.SVG". -- -- * A more flexible approach is to directly call 'renderDia'; see -- "Diagrams.Backend.SVG" for more information. ----------------------------------------------------------------------------- module Diagrams.Backend.SVG.CmdLine ( defaultMain , multiMain , SVG ) where import Diagrams.Prelude hiding (width, height, interval) import Diagrams.Backend.SVG import System.Console.CmdArgs.Implicit hiding (args) import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) import qualified Data.ByteString.Lazy as BS import Data.Maybe (fromMaybe) import Control.Monad (when) import Data.List.Split import System.Environment (getArgs, getProgName) import System.Directory (getModificationTime) import System.Process (runProcess, waitForProcess) import System.IO (openFile, hClose, IOMode(..), hSetBuffering, BufferMode(..), stdout) import System.Exit (ExitCode(..)) import Control.Concurrent (threadDelay) import qualified Control.Exception as Exc (catch, bracket) import Control.Exception (SomeException(..)) #ifdef CMDLINELOOP import System.Posix.Process (executeFile) #endif # if MIN_VERSION_directory(1,2,0) import Data.Time.Clock (UTCTime,getCurrentTime) type ModuleTime = UTCTime getModuleTime :: IO ModuleTime getModuleTime = getCurrentTime #else import System.Time (ClockTime, getClockTime) type ModuleTime = ClockTime getModuleTime :: IO ModuleTime getModuleTime = getClockTime #endif data DiagramOpts = DiagramOpts { width :: Maybe Int , height :: Maybe Int , output :: FilePath , selection :: Maybe String #ifdef CMDLINELOOP , loop :: Bool , src :: Maybe String , interval :: Int #endif } deriving (Show, Data, Typeable) diagramOpts :: String -> Bool -> DiagramOpts diagramOpts prog sel = DiagramOpts { width = def &= typ "INT" &= help "Desired width of the output image" , height = def &= typ "INT" &= help "Desired height of the output image" , output = def &= typFile &= help "Output file" , selection = def &= help "Name of the diagram to render" &= (if sel then typ "NAME" else ignore) #ifdef CMDLINELOOP , loop = False &= help "Run in a self-recompiling loop" , src = def &= typFile &= help "Source file to watch" , interval = 1 &= typ "SECONDS" &= help "When running in a loop, check for changes every n seconds." #endif } &= summary "Command-line diagram generation." &= program prog -- | This is the simplest way to render diagrams, and is intended to -- be used like so: -- -- > ... definitions ... -- > -- > main = defaultMain myDiagram -- -- Compiling this file will result in an executable which takes -- various command-line options for setting the size, output file, -- and so on, and renders @myDiagram@ with the specified options. -- -- Pass @--help@ to the generated executable to see all available -- options. defaultMain :: Diagram SVG R2 -> IO () defaultMain d = do prog <- getProgName args <- getArgs opts <- cmdArgs (diagramOpts prog False) chooseRender opts d #ifdef CMDLINELOOP when (loop opts) (waitForChange Nothing opts prog args) #endif chooseRender :: DiagramOpts -> Diagram SVG R2 -> IO () chooseRender opts d = case splitOn "." (output opts) of [""] -> putStrLn "No output file given." ps | last ps `elem` ["svg"] -> do let sizeSpec = case (width opts, height opts) of (Nothing, Nothing) -> Absolute (Just w, Nothing) -> Width (fromIntegral w) (Nothing, Just h) -> Height (fromIntegral h) (Just w, Just h) -> Dims (fromIntegral w) (fromIntegral h) build = renderDia SVG (SVGOptions sizeSpec Nothing) d BS.writeFile (output opts) (renderSvg build) | otherwise -> putStrLn $ "Unknown file type: " ++ last ps -- | @multiMain@ is like 'defaultMain', except instead of a single -- diagram it takes a list of diagrams paired with names as input. -- The generated executable then takes an argument specifying the -- name of the diagram that should be rendered. This is a -- convenient way to create an executable that can render many -- different diagrams without modifying the source code in between -- each one. multiMain :: [(String, Diagram SVG R2)] -> IO () multiMain ds = do prog <- getProgName opts <- cmdArgs (diagramOpts prog True) case selection opts of Nothing -> putStrLn "No diagram selected." Just sel -> case lookup sel ds of Nothing -> putStrLn $ "Unknown diagram: " ++ sel Just d -> chooseRender opts d #ifdef CMDLINELOOP waitForChange :: Maybe ModuleTime -> DiagramOpts -> String -> [String] -> IO () waitForChange lastAttempt opts prog args = do hSetBuffering stdout NoBuffering go lastAttempt where go lastAtt = do threadDelay (1000000 * interval opts) -- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")" (newBin, newAttempt) <- recompile lastAtt prog (src opts) if newBin then executeFile prog False args Nothing else go $ getFirst (First newAttempt <> First lastAtt) -- | @recompile t prog@ attempts to recompile @prog@, assuming the -- last attempt was made at time @t@. If @t@ is @Nothing@ assume -- the last attempt time is the same as the modification time of the -- binary. If the source file modification time is later than the -- last attempt time, then attempt to recompile, and return the time -- of this attempt. Otherwise (if nothing has changed since the -- last attempt), return @Nothing@. Also return a Bool saying -- whether a successful recompilation happened. recompile :: Maybe ModuleTime -> String -> Maybe String -> IO (Bool, Maybe ModuleTime) recompile lastAttempt prog mSrc = do let errFile = prog ++ ".errors" srcFile = fromMaybe (prog ++ ".hs") mSrc binT <- maybe (getModTime prog) (return . Just) lastAttempt srcT <- getModTime srcFile if (srcT > binT) then do putStr "Recompiling..." status <- Exc.bracket (openFile errFile WriteMode) hClose $ \h -> waitForProcess =<< runProcess "ghc" ["--make", srcFile] Nothing Nothing Nothing Nothing (Just h) if (status /= ExitSuccess) then putStrLn "" >> putStrLn (replicate 75 '-') >> readFile errFile >>= putStr else putStrLn "done." curTime <- getModuleTime return (status == ExitSuccess, Just curTime) else return (False, Nothing) where getModTime f = Exc.catch (Just <$> getModificationTime f) (\(SomeException _) -> return Nothing) #endif diagrams-svg-0.8.0.2/src/Graphics/0000755000000000000000000000000012233035572014762 5ustar0000000000000000diagrams-svg-0.8.0.2/src/Graphics/Rendering/0000755000000000000000000000000012233035572016677 5ustar0000000000000000diagrams-svg-0.8.0.2/src/Graphics/Rendering/SVG.hs0000644000000000000000000002100012233035572017663 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.SVG -- Copyright : (c) 2011 diagrams-svg team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Generic tools for generating SVG files. -- ----------------------------------------------------------------------------- module Graphics.Rendering.SVG ( svgHeader , renderPath , renderClip , renderText , renderStyles , renderTransform , renderMiterLimit ) where -- from base import Data.List (intercalate, intersperse) -- from diagrams-lib import Diagrams.Prelude hiding (Attribute, Render, e, (<>)) import Diagrams.TwoD.Path (getFillRule) import Diagrams.TwoD.Text -- from blaze-svg import Text.Blaze.Svg11 (cr, hr, lr, m, mkPath, vr, z, (!)) import qualified Text.Blaze.Svg11 as S import qualified Text.Blaze.Svg11.Attributes as A -- | @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])) $ 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 where makePath = mkPath $ mapM_ renderTrail trs renderTrail :: Located (Trail R2) -> S.Path renderTrail (viewLoc -> (unp2 -> (x,y), t)) = flip withLine t $ \l -> do m x y mapM_ renderSeg (lineSegments l) if isLoop t then z else return () renderSeg :: Segment Closed R2 -> S.Path renderSeg (Linear (OffsetClosed (unr2 -> (x,0)))) = hr x renderSeg (Linear (OffsetClosed (unr2 -> (0,y)))) = vr y renderSeg (Linear (OffsetClosed (unr2 -> (x,y)))) = lr x y renderSeg (Cubic (unr2 -> (x0,y0)) (unr2 -> (x1,y1)) (OffsetClosed (unr2 -> (x2,y2)))) = cr x0 y0 x1 y1 x2 y2 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 renderText :: Text -> S.Svg renderText (Text tr tAlign str) = S.text_ ! A.transform transformMatrix ! 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 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 -- | Apply a transformation to some already-rendered SVG. renderTransform :: Transformation R2 -> S.Svg -> S.Svg renderTransform t svg = S.g svg ! (A.transform $ S.matrix a1 a2 b1 b2 c1 c2) where (a1,a2,b1,b2,c1,c2) = getMatrix t renderStyles :: Bool -> Style v -> S.Attribute renderStyles ignoreFill s = mconcat . map ($ s) $ [ renderLineColor , if ignoreFill then const (renderAttr A.fillOpacity (Just (0 :: Double))) else renderFillColor , renderLineWidth , renderLineCap , renderLineJoin , renderFillRule , renderDashing , renderOpacity , renderFontSize , 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 = (renderAttr A.stroke lineColorRgb) `mappend` (renderAttr A.strokeOpacity lineColorOpacity) where lineColor_ = getLineColor <$> getAttr s lineColorRgb = colorToRgbString <$> lineColor_ lineColorOpacity = colorToOpacity <$> lineColor_ renderFillColor :: Style v -> S.Attribute renderFillColor s = (renderAttr A.fill fillColorRgb) `mappend` (renderAttr A.fillOpacity fillColorOpacity) where fillColor_ = getFillColor <$> getAttr s fillColorRgb = colorToRgbString <$> fillColor_ fillColorOpacity = colorToOpacity <$> fillColor_ renderOpacity :: Style v -> S.Attribute renderOpacity s = renderAttr A.opacity opacity_ where opacity_ = getOpacity <$> getAttr s renderFillRule :: Style v -> S.Attribute renderFillRule s = renderAttr A.fillRule fillRule_ where fillRule_ = (fillRuleToStr . getFillRule) <$> getAttr s fillRuleToStr :: FillRule -> String fillRuleToStr Winding = "nonzero" fillRuleToStr EvenOdd = "evenodd" renderLineWidth :: Style v -> S.Attribute renderLineWidth s = renderAttr A.strokeWidth lineWidth_ where lineWidth_ = getLineWidth <$> getAttr s renderLineCap :: Style v -> S.Attribute renderLineCap s = renderAttr A.strokeLinecap lineCap_ where lineCap_ = (lineCapToStr . getLineCap) <$> 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) <$> getAttr s lineJoinToStr :: LineJoin -> String lineJoinToStr LineJoinMiter = "miter" lineJoinToStr LineJoinRound = "round" lineJoinToStr LineJoinBevel = "bevel" renderDashing :: Style v -> S.Attribute renderDashing s = (renderAttr A.strokeDasharray arr) `mappend` (renderAttr A.strokeDashoffset dOffset) where getDasharray (Dashing a _) = a getDashoffset :: Dashing -> Double getDashoffset (Dashing _ o) = o dashArrayToStr = intercalate "," . map show dashing_ = getDashing <$> getAttr s arr = (dashArrayToStr . getDasharray) <$> dashing_ dOffset = 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 -- | 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,_) = colorToSRGBA c colorToOpacity :: forall c . Color c => c -> Double colorToOpacity c = a where (_,_,_,a) = colorToSRGBA c