diagrams-svg (empty) → 0.3
raw patch · 6 files changed
+384/−0 lines, 6 filesdep +basedep +blaze-htmldep +blaze-svgsetup-changed
Dependencies added: base, blaze-html, blaze-svg, bytestring, cmdargs, colour, diagrams-core, diagrams-lib, directory, filepath, old-time, process, split, unix, vector-space
Files
- LICENSE +30/−0
- Setup.hs +3/−0
- diagrams-svg.cabal +45/−0
- src/Diagrams/Backend/SVG.hs +73/−0
- src/Diagrams/Backend/SVG/CmdLine.hs +171/−0
- src/Graphics/Rendering/SVG.hs +62/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Felipe Lessa 2011++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.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ diagrams-svg.cabal view
@@ -0,0 +1,45 @@+Name: diagrams-svg+Version: 0.3+Synopsis: SVG backend for diagrams drawing EDSL.+Homepage: http://code.haskell.org/diagrams/+License: BSD3+License-file: LICENSE+Author: Felipe Lessa+Maintainer: felipe.lessa@gmail.com+Stability: Experimental+Category: Graphics+Build-type: Simple+Cabal-version: >=1.6+Description:+ This package provides a modular backend for rendering diagrams+ created with the diagrams EDSL using SVG. It uses+ @blaze-svg@ to be fast, pure-Haskell backend.++Source-repository head+ type: darcs+ location: http://patch-tag.com/r/felipe/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.6+ , old-time >= 1.0 && < 1.2+ , process >= 1.0 && < 1.2+ , directory >= 1.0 && < 1.2+ , filepath >= 1.2 && < 1.4+ , bytestring >= 0.9 && < 1.0+ , vector-space >= 0.7 && < 0.9+ , colour+ , diagrams-core >= 0.5 && < 0.6+ , diagrams-lib >= 0.5 && < 0.6+ , blaze-svg >= 0.1+ , blaze-html >= 0.4 && < 0.5+ , cmdargs >= 0.6 && < 0.9+ , split >= 0.1.2 && < 0.2+ if !os(windows)+ cpp-options: -DCMDLINELOOP+ Build-depends: unix >= 2.4 && < 2.6++ Ghc-options: -Wall
+ src/Diagrams/Backend/SVG.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TypeFamilies+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , TypeSynonymInstances+ , DeriveDataTypeable+ #-}+{-|+ The SVG backend.+-}+module Diagrams.Backend.SVG+ ( SVG(..) -- rendering token+ , Options(..) -- for rendering options specific to SVG+ ) where++-- from base+import Data.Monoid+import Data.Typeable++-- from diagrams-lib+import Diagrams.Prelude hiding ((<>))+import Diagrams.TwoD.Adjust (adjustDia2D)+import Diagrams.TwoD.Text++-- from blaze-svg+import qualified Text.Blaze.Svg11 as S++-- from this package+import qualified Graphics.Rendering.SVG as R++data SVG = SVG+ deriving (Show, Typeable)+++instance Monoid (Render SVG R2) where+ mempty = R $ mempty+ (R r1) `mappend` (R r2_) = R (r1 <> r2_)+++instance Backend SVG R2 where+ data Render SVG R2 = R S.Svg+ 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.+ }++ withStyle _ _ _ d = d++ 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++ adjustDia c opts d = adjustDia2D size setSvgSize c opts d+ where setSvgSize sz o = o { size = sz }++instance Renderable (Segment R2) SVG where+ render c = render c . flip Trail False . (:[])++instance Renderable (Trail R2) SVG where+ render c t = render c $ Path [(p2 (0,0), t)]++instance Renderable (Path R2) SVG where+ render _ = R . R.renderPath++instance Renderable Text SVG where+ render _ = R . R.renderText++-- TODO: instance Renderable Image SVG where
+ src/Diagrams/Backend/SVG/CmdLine.hs view
@@ -0,0 +1,171 @@+{-# 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.+--+-----------------------------------------------------------------------------++module Diagrams.Backend.SVG.CmdLine+ ( defaultMain+ , multiMain+ ) where++import Diagrams.Prelude hiding (width, height, interval)+import Diagrams.Backend.SVG++import System.Console.CmdArgs.Implicit hiding (args)++import Text.Blaze.Renderer.Utf8 (renderHtml)+import qualified Data.ByteString.Lazy as BS++import Prelude hiding (catch)++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 System.Time (ClockTime, getClockTime)+import Control.Concurrent (threadDelay)+import Control.Exception (catch, SomeException(..), bracket)++#ifdef CMDLINELOOP+import System.Posix.Process (executeFile)+#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 (default 400)"++ , height = def+ &= typ "INT"+ &= help "Desired height of the output image (default 400)"++ , 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++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 (output opts) sizeSpec) d+ BS.writeFile (output opts) (renderHtml build)+ | otherwise -> putStrLn $ "Unknown file type: " ++ last ps++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 ClockTime -> 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 ClockTime -> String -> Maybe String -> IO (Bool, Maybe ClockTime)+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 <- 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 <- getClockTime+ return (status == ExitSuccess, Just curTime)++ else return (False, Nothing)++ where getModTime f = catch (Just <$> getModificationTime f)+ (\(SomeException _) -> return Nothing)+#endif
+ src/Graphics/Rendering/SVG.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ViewPatterns, OverloadedStrings #-}+module Graphics.Rendering.SVG+ ( svgHeader+ , renderPath+ , renderText+ ) where++-- from base+import Data.List (intersperse)++-- from diagrams-lib+import Diagrams.Prelude hiding (Render, Attribute, close, e, (<>))+import Diagrams.TwoD.Text++import Text.Blaze.Svg11 ((!), mkPath, m, cr, hr, vr, lr, z)+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+ ! A.version "1.1"+ ! 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"++renderPath :: Path R2 -> S.Svg+renderPath (Path trs) = S.path ! A.d makePath+ where+ makePath = mkPath $ mapM_ renderTrail trs++renderTrail :: (P2, Trail R2) -> S.Path+renderTrail (unp2 -> (x,y), Trail segs closed) = do+ m x y+ mapM_ renderSeg segs+ if closed then z else return ()++renderSeg :: Segment R2 -> S.Path+renderSeg (Linear (unr2 -> (x,0))) = hr x+renderSeg (Linear (unr2 -> (0,y))) = vr y+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+renderText :: Text -> S.Svg+renderText _ = mempty