diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,36 @@ +Copyright (c) 2014 diagrams-canvas team: + + Daniel Bergey + Jeffrey Rosenbluth + Ryan Yates + Brent Yorgey + Andy Gill + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 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-canvas.cabal b/diagrams-canvas.cabal new file mode 100644 --- /dev/null +++ b/diagrams-canvas.cabal @@ -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 diff --git a/src/Diagrams/Backend/Canvas.hs b/src/Diagrams/Backend/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Canvas.hs @@ -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 diff --git a/src/Diagrams/Backend/Canvas/CmdLine.hs b/src/Diagrams/Backend/Canvas/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/Canvas/CmdLine.hs @@ -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 +-- . +-- +----------------------------------------------------------------------------- + +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