diagrams-canvas (empty) → 0.2
raw patch · 6 files changed
+699/−0 lines, 6 filesdep +NumInstancesdep +basedep +blank-canvassetup-changed
Dependencies added: NumInstances, base, blank-canvas, cmdargs, containers, data-default-class, diagrams-core, diagrams-lib, lens, mtl, optparse-applicative, statestack, text, vector-space
Files
- LICENSE +36/−0
- README.md +41/−0
- Setup.hs +3/−0
- diagrams-canvas.cabal +41/−0
- src/Diagrams/Backend/Canvas.hs +449/−0
- src/Diagrams/Backend/Canvas/CmdLine.hs +129/−0
+ LICENSE view
@@ -0,0 +1,36 @@+Copyright (c) 2014 diagrams-canvas team:+ + Daniel Bergey <bergey@alum.mit.edu>+ Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>+ Ryan Yates <fryguybob@gmail.com>+ Brent Yorgey <byorgey@cis.upenn.edu>+ Andy Gill <andygill@ku.edu>++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.
+ README.md view
@@ -0,0 +1,41 @@+diagrams-canvas+===============++diagrams-canvas is a canvas backend for diagrams based on the blank-canvas+https://github.com/ku-fpg/blank-canvas package. +Diagrams is a powerful, flexible, declarative domain-specific language for +creating vector graphics, using the Haskell programming language.+It supports most features defined in [diagrams-lib].++[diagrams-lib]: http://hackage.haskell.org/package/diagrams%2Dlib++# Installation++```+cabal update && cabal install diagrams-canvas+```++# Usage++A simple example that uses _diagrams-canvas_ to draw a square.++```haskell+import Diagrams.Prelude+import Diagrams.Backend.Canvas.CmdLine++b1 = square 20 # lw 0.002++main = mainWith (pad 1.1 b1)+```++Save this to file named `Square.hs` and compile this program:++```+ghc --make -threaded Square.hs+```++This will generate an executable which, when run dispays the resulting+diagrams to http://localhost:3000/++```+$ ./Square -w 750
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ diagrams-canvas.cabal view
@@ -0,0 +1,41 @@+Name: diagrams-canvas+Version: 0.2+Synopsis: HTML5 canvas backend for diagrams drawing EDSL+Description: This package provides a modular backend for rendering+ diagrams created with the diagrams EDSL using an+ HTML5 canvas.+Homepage: http://projects.haskell.org/diagrams/+License: BSD3+License-file: LICENSE+Author: Jeffrey Rosenbluth, Ryan Yates, Brent Yorgey, Andy Gill+Maintainer: diagrams-discuss@googlegroups.com+Bug-reports: http://github.com/diagrams/diagrams-canvas/issues+Stability: Experimental+Category: Graphics+Build-type: Simple+Extra-source-files: README.md+Cabal-version: >=1.10+Source-repository head+ type: git+ location: https://github.com/diagrams/diagrams-canvas.git++Library+ Exposed-modules: Diagrams.Backend.Canvas+ Diagrams.Backend.Canvas.CmdLine+ Hs-source-dirs: src+ Build-depends: base >= 4.6 && < 4.8,+ mtl >= 2.0 && < 3.0,+ vector-space >= 0.7 && < 0.9,+ NumInstances >= 1.0 && < 1.4,+ diagrams-core >= 1.2 && < 1.3,+ diagrams-lib >= 1.2 && < 1.3,+ cmdargs >= 0.6 && < 0.11,+ blank-canvas >= 0.4 && < 0.5,+ lens >= 3.8 && < 4.3,+ containers >= 0.3 && < 0.6,+ text >= 1.0 && < 1.2,+ data-default-class >= 0.0.1 && < 0.1,+ statestack >= 0.2 && <0.3,+ optparse-applicative >= 0.9 && < 0.10++ Default-language: Haskell2010
+ src/Diagrams/Backend/Canvas.hs view
@@ -0,0 +1,449 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-------------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Canvas+-- Copyright : (c) 2010 - 2014 diagrams-canvas team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- A full-featured rendering backend for diagrams using Canvas.+-- Implemented using the blank-canvas platform.+--+-- To invoke the Canvas backend, you have three options.+--+-- * You can use the "Diagrams.Backend.Canvas.CmdLine" module to create+-- standalone executables which will display the diagram in a browser+-- using a web service.+--+-- * You can use the 'renderCanvas' function provided by this module,+-- which gives you more programmatic control over when and+-- how images are displayed (making it east to, for example, write a+-- single program that displays multiple images, or one that diaplays+-- images dynamically based on user input, and so on).+--+-- * For the most flexiblity you can invoke the 'renderDia' method from+-- 'Diagrams.Core.Types.Backend' instance for @Canvas@. 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 contraints). @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 ~ Canvas@ and @v ~ R2@, we have+--+-- > data Options Canvas R2 = CanvaseOptions+-- > { _size :: SizeSpec2D -- ^^ The requested size+-- > }+--+-- @+-- data family Render Canvas R2 = C (RenderM ())+-- @+--+-- @+-- type family Result Canvas R2 = Canvas ()+-- @+--+-- So the type of 'renderDia' resolves to+--+-- @+-- renderDia :: Canvas -> Options Canvas R2 -> QDiagram Canvas R2 m ->+-- Canvas()+-- @+--+-- which you could call like @renderDia Canvas (CanvaseOptions (width 250))+-- myDiagram@+--+------------------------------------------------------------------------------++module Diagrams.Backend.Canvas++ ( Canvas(..) -- rendering token+ , B+ , Options(..) -- for rendering options specific to Canvas+ + , renderCanvas++ ) where++import Control.Arrow ((***))+import Control.Lens hiding (transform, (#))+import Control.Monad.State (when, State, evalState)+import qualified Control.Monad.StateStack as SS+import Control.Monad.Trans (lift)++import Data.Default.Class+import qualified Data.Foldable as F+import Data.Maybe (catMaybes, isJust, fromJust, fromMaybe)+import Data.NumInstances ()+import qualified Data.Text as T+import Data.Tree (Tree(Node))+import Data.Typeable (Typeable)+import Data.Word (Word8)++import Diagrams.Attributes +import Diagrams.Prelude hiding (fillTexture, moveTo, stroke)+import Diagrams.TwoD.Adjust (adjustDia2D)+import Diagrams.TwoD.Attributes (splitTextureFills)+import Diagrams.TwoD.Path (Clip (Clip))+import Diagrams.TwoD.Text+import Diagrams.TwoD.Types (R2(..))++import Diagrams.Core.Compile+import Diagrams.Core.Transform (matrixHomRep)+import Diagrams.Core.Types (Annotation (..))++import qualified Graphics.Blank as BC+import qualified Graphics.Blank.Style as S++-- | This data declaration is simply used as a token to distinguish +-- this rendering engine.+data Canvas = Canvas+ deriving (Eq, Ord, Read, Show, Typeable)++type B = Canvas++data CanvasState = CanvasState { _accumStyle :: Style R2+ , _csPos :: (Float, Float) }++makeLenses ''CanvasState++instance Default CanvasState where+ def = CanvasState { _accumStyle = mempty+ , _csPos = (0,0) }++type RenderM a = SS.StateStackT CanvasState BC.Canvas a++liftC :: BC.Canvas a -> RenderM a+liftC = lift++runRenderM :: RenderM a -> BC.Canvas a+runRenderM = flip SS.evalStateStackT def++instance Monoid (Render Canvas R2) where+ mempty = C $ return ()+ (C c1) `mappend` (C c2) = C (c1 >> c2)++instance Backend Canvas R2 where+ data Render Canvas R2 = C (RenderM ())+ type Result Canvas R2 = BC.Canvas ()+ data Options Canvas R2 = CanvasOptions+ { _canvasSize :: SizeSpec2D -- ^ the requested size+ }++ renderRTree :: Canvas -> Options Canvas R2 -> RTree Canvas R2 Annotation + -> Result Canvas R2+ renderRTree _ _ rt = evalState canvasOutput initialCanvasRenderState+ where+ canvasOutput :: State CanvasRenderState (BC.Canvas ())+ canvasOutput = do+ let C r = toRender rt+ return $ runRenderM $ r++ adjustDia c opts d = adjustDia2D size c opts (d # reflectY)++runC :: Render Canvas R2 -> RenderM ()+runC (C r) = r++toRender :: RTree Canvas R2 Annotation -> Render Canvas R2+toRender = fromRTree+ . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))+ . (:[])+ . splitTextureFills+ where+ fromRTree (Node (RPrim p) _) = render Canvas p+ fromRTree (Node (RStyle sty) rs) = C $ do+ save+ canvasStyle sty+ accumStyle %= (<> sty)+ runC $ F.foldMap fromRTree rs+ restore+ fromRTree (Node _ rs) = F.foldMap fromRTree rs++data CanvasRenderState = CanvasRenderState++initialCanvasRenderState :: CanvasRenderState+initialCanvasRenderState = CanvasRenderState++getSize :: Options Canvas R2 -> SizeSpec2D+getSize (CanvasOptions {_canvasSize = s}) = s++setSize :: Options Canvas R2 -> SizeSpec2D -> Options Canvas R2+setSize o s = o {_canvasSize = s}++size :: Lens' (Options Canvas R2) SizeSpec2D+size = lens getSize setSize++move :: (Float, Float) -> RenderM ()+move p = do csPos .= p++save :: RenderM ()+save = SS.save >> liftC (BC.save ())++restore :: RenderM ()+restore = liftC (BC.restore ()) >> SS.restore++newPath :: RenderM ()+newPath = liftC $ BC.beginPath ()++closePath :: RenderM ()+closePath = liftC $ BC.closePath ()++moveTo :: Double -> Double -> RenderM ()+moveTo x y = do+ let x' = realToFrac x+ y' = realToFrac y+ liftC $ BC.moveTo (x', y')+ move (x', y')++relLineTo :: Double -> Double -> RenderM ()+relLineTo x y = do+ p <- use csPos+ let p' = p + (realToFrac x, realToFrac y)+ liftC $ BC.lineTo p'+ move p'++relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> RenderM ()+relCurveTo ax ay bx by cx cy = do+ p <- use csPos+ let [(ax',ay'),(bx',by'),(cx',cy')] = map ((p +) . (realToFrac *** realToFrac))+ [(ax,ay),(bx,by),(cx,cy)]+ liftC $ BC.bezierCurveTo (ax',ay',bx',by',cx',cy')+ move (cx', cy')++-- | Get an accumulated style attribute from the render monad state.+getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)+getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle++-- | From the HTML5 canvas specification regarding line width:+--+-- "On setting, zero, negative, infinite, and NaN values must be+-- ignored, leaving the value unchanged; other values must change+-- the current value to the new value.+--+-- Hence we must implement a line width of zero by simply not+-- sending a stroke command.+stroke :: RenderM ()+stroke = do+ -- The default value of 0.5 is somewhat arbitary since lineWidth should neve+ -- be 'Nothing'. 0.5 is choose since it is the lower bound of the+ -- default.+ w <- fromMaybe 0.5 <$> getStyleAttrib (fromOutput . getLineWidth)+ when (w > 0) (liftC $ BC.stroke ())++fill :: RenderM ()+fill = liftC $ BC.fill ()++clip :: RenderM ()+clip = liftC $ BC.clip ()++byteRange :: Double -> Word8+byteRange d = floor (d * 255)++data TextureUse = Fill | Strk++texture :: TextureUse -> Texture -> Double -> RenderM()+texture u (SC (SomeColor c)) o = case u of+ Fill -> liftC . S.fillStyle $ s+ Strk -> liftC . S.strokeStyle $ s+ where s = showColorJS c o++texture u (LG g) _ = liftC $ do+ grd <- BC.createLinearGradient (x0, y0, x1, y1)+ mapM_ (flip BC.addColorStop $ grd) stops+ case u of+ Fill -> S.fillStyle grd+ Strk -> S.strokeStyle grd+ where+ (x0', y0') = unp2 $ transform (g^.lGradTrans) (g^.lGradStart)+ (x1', y1') = unp2 $ transform (g^.lGradTrans) (g^.lGradEnd)+ (x0, y0, x1, y1) = ( realToFrac x0', realToFrac y0'+ , realToFrac x1', realToFrac y1')+ stops = map (\s -> ( realToFrac (s^.stopFraction)+ , showColorJS (s^.stopColor) 1)) (g^.lGradStops)++texture u (RG g) _ = liftC $ do+ grd <- BC.createRadialGradient (x0, y0, r0, x1, y1, r1)+ mapM_ (flip BC.addColorStop $ grd) stops+ case u of+ Fill -> S.fillStyle grd+ Strk -> S.strokeStyle grd+ where+ (r0, r1) = (s * realToFrac (g^.rGradRadius0), s * realToFrac (g^.rGradRadius1))+ (x0', y0') = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter0)+ (x1', y1') = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter1)+ (x0, y0, x1, y1) = ( realToFrac x0', realToFrac y0'+ , realToFrac x1', realToFrac y1')+ stops = map (\st -> ( realToFrac (st^.stopFraction)+ , showColorJS (st^.stopColor) 1)) (g^.rGradStops)+ s = realToFrac . avgScale $ (g^.rGradTrans)++showColorJS :: (Color c) => c -> Double -> T.Text+showColorJS c o = T.concat+ [ "rgba("+ , s r, ","+ , s g, ","+ , s b, ","+ , T.pack (show $ a * o)+ , ")"+ ]+ where s :: Double -> T.Text+ s = T.pack . show . byteRange+ (r,g,b,a) = colorToSRGBA . toAlphaColour $ c++canvasTransform :: T2 -> RenderM ()+canvasTransform tr = liftC $ BC.transform vs+ where + [[ax, ay], [bx, by], [tx, ty]] = matrixHomRep tr+ vs = (realToFrac ax,realToFrac ay+ ,realToFrac bx,realToFrac by+ ,realToFrac tx,realToFrac ty)++strokeTexture :: Texture -> Double -> RenderM ()+strokeTexture = texture Strk++fillTexture :: Texture -> Double -> RenderM ()+fillTexture = texture Fill++fromLineCap :: LineCap -> T.Text+fromLineCap LineCapRound = "round"+fromLineCap LineCapSquare = "square"+fromLineCap _ = "butt"++fromLineJoin :: LineJoin -> T.Text+fromLineJoin LineJoinRound = "round"+fromLineJoin LineJoinBevel = "bevel"+fromLineJoin _ = "miter"++showFontJS :: FontWeight -> FontSlant -> Double -> String -> T.Text+showFontJS wgt slant sz fnt = T.concat [a, " ", b, " ", c, " ", d]+ where+ a = case wgt of+ FontWeightNormal -> ""+ FontWeightBold -> "bold"+ b = case slant of+ FontSlantNormal -> ""+ FontSlantItalic -> "italic"+ FontSlantOblique -> "oblique"+ c = T.concat [T.pack $ show sz, "pt"]+ d = T.pack fnt++renderC :: (Renderable a Canvas, V a ~ R2) => a -> RenderM ()+renderC a = case (render Canvas a) of C r -> r++canvasStyle :: Style v -> RenderM ()+canvasStyle s = sequence_+ . catMaybes $ [ handle clip' + , handle lWidth+ , handle lCap+ , handle lJoin+ ]+ where handle :: (AttributeClass a) => (a -> RenderM ()) -> Maybe (RenderM ())+ handle f = f `fmap` getAttr s+ clip' = mapM_ (\p -> canvasPath p >> clip) . op Clip+ lWidth = liftC . BC.lineWidth . realToFrac . fromOutput . getLineWidth+ lCap = liftC . BC.lineCap . fromLineCap . getLineCap+ lJoin = liftC . BC.lineJoin . fromLineJoin . getLineJoin++instance Renderable (Segment Closed R2) Canvas where+ render _ (Linear (OffsetClosed (R2 x y))) = C $ relLineTo x y+ render _ (Cubic (R2 x1 y1)+ (R2 x2 y2)+ (OffsetClosed (R2 x3 y3)))+ = C $ relCurveTo x1 y1 x2 y2 x3 y3++instance Renderable (Trail R2) Canvas where+ render _ = withTrail renderLine renderLoop+ where+ renderLine ln = C $ do+ mapM_ renderC (lineSegments ln)+ renderLoop lp = C $ do+ case loopSegments lp of+ (segs, Linear _) -> mapM_ renderC segs+ _ -> mapM_ renderC (lineSegments . cutLoop $ lp)+ closePath++instance Renderable (Path R2) Canvas where+ render _ p = C $ do+ canvasPath p+ f <- getStyleAttrib getFillTexture+ s <- getStyleAttrib getLineTexture+ o <- fromMaybe 1 <$> getStyleAttrib getOpacity+ save+ when (isJust f) (fillTexture (fromJust f) o >> fill)+ strokeTexture (fromMaybe (SC (SomeColor (black :: Colour Double))) s) o+ stroke+ restore++-- Add a path to the Canvas context, without stroking or filling it.+canvasPath :: Path R2 -> RenderM ()+canvasPath (Path trs) = do+ newPath+ F.mapM_ renderTrail trs+ where+ renderTrail (viewLoc -> (unp2 -> p, tr)) = do+ uncurry moveTo p+ renderC tr++instance Renderable Text Canvas where+ render _ (Text tt tn al str) = C $ do+ isLocal <- fromMaybe True <$> getStyleAttrib getFontSizeIsLocal+ tf <- fromMaybe "Calibri" <$> getStyleAttrib getFont+ sz <- fromMaybe 12 <$> getStyleAttrib (fromOutput . getFontSize)+ slant <- fromMaybe FontSlantNormal <$> getStyleAttrib getFontSlant+ fw <- fromMaybe FontWeightNormal <$> getStyleAttrib getFontWeight+ tx <- fromMaybe (SC (SomeColor (black :: Colour Double)))+ <$> getStyleAttrib getFillTexture+ o <- fromMaybe 1 <$> getStyleAttrib getOpacity+ let fSize = if isLocal+ then avgScale tt * sz+ else sz+ fnt = showFontJS fw slant fSize tf+ vAlign = case al of+ BaselineText -> T.pack "alphabetic"+ BoxAlignedText _ h -> case h of+ h' | h' <= 0.25 -> T.pack "bottom"+ h' | h' >= 0.75 -> T.pack "top"+ _ -> T.pack "middle"+ hAlign = case al of+ BaselineText -> T.pack "start"+ BoxAlignedText w _ -> case w of+ w' | w' <= 0.25 -> T.pack "start"+ w' | w' >= 0.75 -> T.pack "end"+ _ -> T.pack "center"+ save+ liftC $ BC.textBaseline vAlign+ liftC $ BC.textAlign hAlign+ liftC $ BC.font fnt+ fillTexture tx o+ canvasTransform (tn <> reflectionY)+ liftC $ BC.fillText (T.pack str, 0, 0)+ restore++-- instance Renderable (DImage External) Canvas where+ -- render _ (DImage path w h tr) = C $ do+ -- let ImageRef file = path+ -- C.save+ -- C.canvasTransform (tr <> reflectionY)+ -- img <- liftC $ BC.newImage (T.pack file)+ -- liftC $ BC.drawImage (img, [0, 0, fromIntegral w, fromIntegral h])+ -- C.restore++renderCanvas :: Int -> SizeSpec2D -> Diagram Canvas R2 -> IO ()+renderCanvas port sizeSpec d = BC.blankCanvas (fromIntegral port) . flip BC.send $ img+ where+ img = renderDia Canvas (CanvasOptions sizeSpec) d
+ src/Diagrams/Backend/Canvas/CmdLine.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.Backend.Canvas.CmdLine+-- Copyright : (c) 2011-2014 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 Canvas 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.+--+-- * 'mainWith' is a generic form that does all of the above but with+-- a slightly scarier type. See "Diagrams.Backend.CmdLine". This+-- form can also take a function type that has a suitable final result+-- (any of arguments to the above types) and 'Parseable' arguments.+--+-- 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.+--+-- * Use a function with 'mainWith'. This may require making+-- 'Parseable' instances for custom argument types.+--+-- * Make a new 'Mainable' instance. This may require a newtype+-- wrapper on your diagram type to avoid the existing instances.+-- This gives you more control over argument parsing, intervening+-- steps, and diagram creation.+--+-- * Build option records and pass them along with a diagram to 'mainRender'+-- from "Diagrams.Backend.CmdLine".+--+-- For a tutorial on command-line diagram creation see+-- <http://projects.haskell.org/diagrams/doc/cmdline.html>.+--+-----------------------------------------------------------------------------++module Diagrams.Backend.Canvas.CmdLine+ ( + -- * General form of @main@+ -- $mainWith+ mainWith++ -- * Supported froms of @main@+ , defaultMain+ , multiMain+ , Canvas+ , B+ ) where++import Diagrams.Prelude hiding (width, height, option, (<>), value)+import Diagrams.Backend.CmdLine hiding (width, height)+import Diagrams.Backend.Canvas+import qualified Graphics.Blank as BC++import Data.Data+import Control.Lens (makeLenses, (^.))+import Options.Applicative++data DiaOpts = DiaOpts + { _width :: Maybe Int -- ^ Final output width of diagram.+ , _height :: Maybe Int -- ^ Final height of diagram.+ , _port :: Int -- ^ Port on which to start web server.+ } deriving (Show, Data, Typeable)++makeLenses ''DiaOpts++diaOpts :: Parser DiaOpts+diaOpts = DiaOpts+ <$> (optional . option)+ (long "width" <> short 'w'+ <> metavar "WIDTH"+ <> help "Desired WIDTH of the output image")+ <*> (optional . option)+ (long "height" <> short 'h'+ <> metavar "HEIGHT"+ <> help "Desired HEIGHT of the output image")+ <*> option+ (long "port" <> short 'p' + <> value 3000+ <> metavar "PORT"+ <> help "Port on which to satrt the web server (default 3000)")++instance Parseable DiaOpts where+ parser = diaOpts+ +defaultMain :: Diagram Canvas R2 -> IO ()+defaultMain = mainWith+ +instance Mainable (Diagram Canvas R2) where+ type MainOpts (Diagram Canvas R2) = DiaOpts+ + mainRender opts d = canvasRender opts d++canvasRender :: DiaOpts -> Diagram Canvas R2 -> IO ()+canvasRender opts d = BC.blankCanvas (fromIntegral (opts^.port)) (canvasDia opts d)++canvasDia :: DiaOpts -> Diagram Canvas R2 -> BC.DeviceContext -> IO ()+canvasDia opts d context = do+ BC.send context $+ renderDia + Canvas + (CanvasOptions + (mkSizeSpec + (fromIntegral <$> opts^.width) + (fromIntegral <$> opts^.height))) + d++multiMain :: [(String, Diagram Canvas R2)] -> IO ()+multiMain = mainWith++instance Mainable [(String, Diagram Canvas R2)] where+ type MainOpts [(String, Diagram Canvas R2)] = + (MainOpts (Diagram Canvas R2), DiagramMultiOpts)++ mainRender = defaultMultiMainRender