diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/diagrams-svg.cabal b/diagrams-svg.cabal new file mode 100644 --- /dev/null +++ b/diagrams-svg.cabal @@ -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 diff --git a/src/Diagrams/Backend/SVG.hs b/src/Diagrams/Backend/SVG.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/SVG.hs @@ -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 diff --git a/src/Diagrams/Backend/SVG/CmdLine.hs b/src/Diagrams/Backend/SVG/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/SVG/CmdLine.hs @@ -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 diff --git a/src/Graphics/Rendering/SVG.hs b/src/Graphics/Rendering/SVG.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/SVG.hs @@ -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