diagrams-canvas 0.3.0.4 → 1.3
raw patch · 6 files changed
+208/−169 lines, 6 filesdep −vector-spacedep ~basedep ~diagrams-coredep ~diagrams-libnew-uploader
Dependencies removed: vector-space
Dependency ranges changed: base, diagrams-core, diagrams-lib
Files
- CHANGELOG.md +89/−0
- CHANGES.md +0/−34
- LICENSE +2/−0
- diagrams-canvas.cabal +6/−6
- src/Diagrams/Backend/Canvas.hs +76/−94
- src/Diagrams/Backend/Canvas/CmdLine.hs +35/−35
+ CHANGELOG.md view
@@ -0,0 +1,89 @@+# Change Log++## [1.3](https://github.com/diagrams/diagrams-canvas/tree/v1.3) (19 April 2015)++- release to coincide with 1.3++## [v0.3.0.4](https://github.com/diagrams/diagrams-canvas/tree/v0.3.0.4) (2015-04-03)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.3.0.3...v0.3.0.4)++## [v0.3.0.3](https://github.com/diagrams/diagrams-canvas/tree/v0.3.0.3) (2015-01-13)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.3.0.2...v0.3.0.3)++## [v0.3.0.2](https://github.com/diagrams/diagrams-canvas/tree/v0.3.0.2) (2014-11-17)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.3.0.1...v0.3.0.2)++**Closed issues:**++- Building with HEAD gives the error "local access only" at localhost:3000 [\#10](https://github.com/diagrams/diagrams-canvas/issues/10)++**Merged pull requests:**++- typos in comments [\#14](https://github.com/diagrams/diagrams-canvas/pull/14) ([ggreif](https://github.com/ggreif))++- Bump lens upper version bounds [\#13](https://github.com/diagrams/diagrams-canvas/pull/13) ([RyanGlScott](https://github.com/RyanGlScott))++- New Stuff x [\#12](https://github.com/diagrams/diagrams-canvas/pull/12) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Diagram B [\#11](https://github.com/diagrams/diagrams-canvas/pull/11) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++## [v0.3.0.1](https://github.com/diagrams/diagrams-canvas/tree/v0.3.0.1) (2014-10-08)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.3...v0.3.0.1)++**Closed issues:**++- API blank canvas change [\#7](https://github.com/diagrams/diagrams-canvas/issues/7)++**Merged pull requests:**++- Bump NumInstances upper version bounds [\#9](https://github.com/diagrams/diagrams-canvas/pull/9) ([RyanGlScott](https://github.com/RyanGlScott))++- port to linear [\#6](https://github.com/diagrams/diagrams-canvas/pull/6) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++## [v0.3](https://github.com/diagrams/diagrams-canvas/tree/v0.3) (2014-09-19)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.2.0.3...v0.3)++**Closed issues:**++- Does not support optparse-applicative-0.10 [\#4](https://github.com/diagrams/diagrams-canvas/issues/4)++**Merged pull requests:**++- Using new version of blank canvas [\#8](https://github.com/diagrams/diagrams-canvas/pull/8) ([andygill](https://github.com/andygill))++## [v0.2.0.3](https://github.com/diagrams/diagrams-canvas/tree/v0.2.0.3) (2014-09-11)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.2.0.2...v0.2.0.3)++**Merged pull requests:**++- Bump text upper version bounds [\#5](https://github.com/diagrams/diagrams-canvas/pull/5) ([RyanGlScott](https://github.com/RyanGlScott))++## [v0.2.0.2](https://github.com/diagrams/diagrams-canvas/tree/v0.2.0.2) (2014-09-07)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.2.0.1...v0.2.0.2)++## [v0.2.0.1](https://github.com/diagrams/diagrams-canvas/tree/v0.2.0.1) (2014-08-22)++[Full Changelog](https://github.com/diagrams/diagrams-canvas/compare/v0.2...v0.2.0.1)++## [v0.2](https://github.com/diagrams/diagrams-canvas/tree/v0.2) (2014-07-08)++**Closed issues:**++- Text with `Local` font size has incorrect vertical alignment. [\#1](https://github.com/diagrams/diagrams-canvas/issues/1)++**Merged pull requests:**++- Apply accumulated uniform scaling to text size [\#3](https://github.com/diagrams/diagrams-canvas/pull/3) ([bergey](https://github.com/bergey))++- Update .cabal version bounds [\#2](https://github.com/diagrams/diagrams-canvas/pull/2) ([bergey](https://github.com/bergey))++++\* *This Change Log was automatically generated by [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)*
− CHANGES.md
@@ -1,34 +0,0 @@-0.3.0.4 (2 April 2015)------------------------- - allow `lens-4.9`- - allow `vector-space-0.10`--0.3.0.3 (13 Jan 2015)------------------------- Allow `vector-space-0.9`-- Allow `lens-4.7`--0.3.0.2 (17 November 2014)------------------------------ Allow `lens-4.6`--0.3.0.1 (8 October 2014)---------------------------- Allow `optparse-applicative-0.11`-- Allow `NumInstances-1.4`--0.3 (20 September 2014)--------------------------- Allow & require `blank-canvas-0.5.*`-- Allow `text-1.2`-- Allow & require `optparse-applicative-0.10.*`--0.2.0.1 (22 August 2014)---------------------------- Allow lens-4.4
LICENSE view
@@ -1,7 +1,9 @@ Copyright (c) 2014 diagrams-canvas team: Daniel Bergey <bergey@alum.mit.edu>+ Christopher Chalmers <c.chalmers@me.com> Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com>+ Ryan Scott Ryan Yates <fryguybob@gmail.com> Brent Yorgey <byorgey@cis.upenn.edu> Andy Gill <andygill@ku.edu>
diagrams-canvas.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-canvas-Version: 0.3.0.4+Version: 1.3 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@@ -13,7 +13,8 @@ Stability: Experimental Category: Graphics Build-type: Simple-Extra-source-files: README.md, CHANGES.md+Extra-source-files: README.md, CHANGELOG.md+Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 Cabal-version: >=1.10 Source-repository head type: git@@ -23,12 +24,11 @@ Exposed-modules: Diagrams.Backend.Canvas Diagrams.Backend.Canvas.CmdLine Hs-source-dirs: src- Build-depends: base >= 4.6 && < 4.8,+ Build-depends: base >= 4.6 && < 4.9, mtl >= 2.0 && < 3.0,- vector-space >= 0.7 && < 0.11, NumInstances >= 1.0 && < 1.5,- diagrams-core >= 1.2 && < 1.3,- diagrams-lib >= 1.2 && < 1.3,+ diagrams-core >= 1.3 && < 1.4,+ diagrams-lib >= 1.3 && < 1.4, cmdargs >= 0.6 && < 0.11, blank-canvas >= 0.5 && < 0.6, lens >= 4.0 && < 4.10,
src/Diagrams/Backend/Canvas.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -46,26 +47,26 @@ -- 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 Options Canvas V2 Double = CanvasOptions+-- > { _size :: SizeSpec V2 -- ^^ The requested size -- > } -- -- @--- data family Render Canvas R2 = C (RenderM ())+-- data family Render Canvas V2 Double = C (RenderM ()) -- @ -- -- @--- type family Result Canvas R2 = Canvas ()+-- type family Result Canvas V2 Double = Canvas () -- @ -- -- So the type of 'renderDia' resolves to -- -- @--- renderDia :: Canvas -> Options Canvas R2 -> QDiagram Canvas R2 m ->+-- renderDia :: Canvas -> Options Canvas V2 Double -> QDiagram Canvas V2 Double m -> -- Canvas() -- @ ----- which you could call like @renderDia Canvas (CanvaseOptions (width 250))+-- which you could call like @renderDia Canvas (CanvasOptions (width 250)) -- myDiagram@ -- ------------------------------------------------------------------------------@@ -80,7 +81,6 @@ ) where -import Control.Arrow ((***)) import Control.Lens hiding (transform, (#)) import Control.Monad.State (when, State, evalState) import qualified Control.Monad.StateStack as SS@@ -96,12 +96,11 @@ import Data.Word (Word8) import Diagrams.Attributes-import Diagrams.Prelude hiding (fillTexture, moveTo, stroke)+import Diagrams.Prelude hiding (fillTexture, moveTo, stroke, size) 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)@@ -117,7 +116,10 @@ type B = Canvas -data CanvasState = CanvasState { _accumStyle :: Style R2+type instance V Canvas = V2+type instance N Canvas = Double++data CanvasState = CanvasState { _accumStyle :: Style V2 Double , _csPos :: (Double, Double) } makeLenses ''CanvasState@@ -134,19 +136,19 @@ runRenderM :: RenderM a -> BC.Canvas a runRenderM = flip SS.evalStateStackT def -instance Monoid (Render Canvas R2) where+instance Monoid (Render Canvas V2 Double) 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+instance Backend Canvas V2 Double where+ data Render Canvas V2 Double = C (RenderM ())+ type Result Canvas V2 Double = BC.Canvas ()+ data Options Canvas V2 Double = CanvasOptions+ { _canvasSize :: SizeSpec V2 Double -- ^ the requested size } - renderRTree :: Canvas -> Options Canvas R2 -> RTree Canvas R2 Annotation- -> Result Canvas R2+ renderRTree :: Canvas -> Options Canvas V2 Double -> RTree Canvas V2 Double Annotation+ -> Result Canvas V2 Double renderRTree _ _ rt = evalState canvasOutput initialCanvasRenderState where canvasOutput :: State CanvasRenderState (BC.Canvas ())@@ -156,10 +158,10 @@ adjustDia c opts d = adjustDia2D size c opts (d # reflectY) -runC :: Render Canvas R2 -> RenderM ()+runC :: Render Canvas V2 Double -> RenderM () runC (C r) = r -toRender :: RTree Canvas R2 Annotation -> Render Canvas R2+toRender :: RTree Canvas V2 Double Annotation -> Render Canvas V2 Double toRender = fromRTree . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double))) . (:[])@@ -179,13 +181,13 @@ initialCanvasRenderState :: CanvasRenderState initialCanvasRenderState = CanvasRenderState -getSize :: Options Canvas R2 -> SizeSpec2D+getSize :: Options Canvas V2 Double -> SizeSpec V2 Double getSize (CanvasOptions {_canvasSize = s}) = s -setSize :: Options Canvas R2 -> SizeSpec2D -> Options Canvas R2+setSize :: Options Canvas V2 Double -> (SizeSpec V2 Double) -> Options Canvas V2 Double setSize o s = o {_canvasSize = s} -size :: Lens' (Options Canvas R2) SizeSpec2D+size :: Lens' (Options Canvas V2 Double)(SizeSpec V2 Double) size = lens getSize setSize move :: (Double, Double) -> RenderM ()@@ -205,23 +207,20 @@ moveTo :: Double -> Double -> RenderM () moveTo x y = do- let x' = realToFrac x- y' = realToFrac y- liftC $ BC.moveTo (x', y')- move (x', 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)+ let p' = p + (x, 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)]+ let [(ax',ay'),(bx',by'),(cx',cy')] = map (p +) [(ax,ay),(bx,by),(cx,cy)] liftC $ BC.bezierCurveTo (ax',ay',bx',by',cx',cy') move (cx', cy') @@ -242,8 +241,8 @@ -- The default value of 0.5 is somewhat arbitary since lineWidth should never -- 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 ())+ w <- fromMaybe 0.5 <$> getStyleAttrib getLineWidth+ when (w > (0 :: Double)) (liftC $ BC.stroke ()) fill :: RenderM () fill = liftC $ BC.fill ()@@ -254,58 +253,44 @@ 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+texture :: (forall a. S.Style a => a -> BC.Canvas ()) -> Texture Double -> Double -> RenderM()+texture styleFn (SC (SomeColor c)) o = liftC . styleFn $ s where s = showColorJS c o -texture u (LG g) _ = liftC $ do+texture styleFn (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+ styleFn 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)+ (x0, y0) = unp2 $ transform (g^.lGradTrans) (g^.lGradStart)+ (x1, y1) = unp2 $ transform (g^.lGradTrans) (g^.lGradEnd)+ stops = map (\s -> ( s^.stopFraction , showColorJS (s^.stopColor) 1)) (g^.lGradStops) -texture u (RG g) _ = liftC $ do+texture styleFn (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+ styleFn 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)+ (r0, r1) = (s * g^.rGradRadius0, s * g^.rGradRadius1)+ (x0, y0) = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter0)+ (x1, y1) = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter1)+ stops = map (\st -> ( st^.stopFraction , showColorJS (st^.stopColor) 1)) (g^.rGradStops)+ s = 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)+ , s (realToFrac r), ","+ , s (realToFrac g), ","+ , s (realToFrac b), ","+ , T.pack (show $ (realToFrac a) * o) , ")" ] where s :: Double -> T.Text s = T.pack . show . byteRange (r,g,b,a) = colorToSRGBA . toAlphaColour $ c -canvasTransform :: T2 -> RenderM ()+canvasTransform :: T2 Double -> RenderM () canvasTransform tr = liftC $ BC.transform vs where [[ax, ay], [bx, by], [tx, ty]] = matrixHomRep tr@@ -313,11 +298,11 @@ ,realToFrac bx,realToFrac by ,realToFrac tx,realToFrac ty) -strokeTexture :: Texture -> Double -> RenderM ()-strokeTexture = texture Strk+strokeTexture :: Texture Double -> Double -> RenderM ()+strokeTexture = texture S.strokeStyle -fillTexture :: Texture -> Double -> RenderM ()-fillTexture = texture Fill+fillTexture :: Texture Double -> Double -> RenderM ()+fillTexture = texture S.fillStyle fromLineCap :: LineCap -> BC.LineEndCap fromLineCap LineCapRound = BC.RoundCap@@ -342,10 +327,10 @@ c = T.concat [T.pack $ show sz, "pt"] d = T.pack fnt -renderC :: (Renderable a Canvas, V a ~ R2) => a -> RenderM ()+renderC :: (Renderable a Canvas, V a ~ V2, N a ~ Double) => a -> RenderM () renderC a = case (render Canvas a) of C r -> r -canvasStyle :: Style v -> RenderM ()+canvasStyle :: Style v Double -> RenderM () canvasStyle s = sequence_ . catMaybes $ [ handle clip' , handle lWidth@@ -355,18 +340,18 @@ 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+ lWidth = liftC . BC.lineWidth . getLineWidth lCap = liftC . BC.lineCap . fromLineCap . getLineCap- lJoin = liftC . BC.lineJoin . fromLineJoin . getLineJoin+ 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)))+instance Renderable (Segment Closed V2 Double) Canvas where+ render _ (Linear (OffsetClosed (V2 x y))) = C $ relLineTo x y+ render _ (Cubic (V2 x1 y1)+ (V2 x2 y2)+ (OffsetClosed (V2 x3 y3))) = C $ relCurveTo x1 y1 x2 y2 x3 y3 -instance Renderable (Trail R2) Canvas where+instance Renderable (Trail V2 Double) Canvas where render _ = withTrail renderLine renderLoop where renderLine ln = C $ do@@ -377,20 +362,20 @@ _ -> mapM_ renderC (lineSegments . cutLoop $ lp) closePath -instance Renderable (Path R2) Canvas where+instance Renderable (Path V2 Double) 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+ when (isJust f) (fillTexture (fromJust f) (realToFrac o) >> fill)+ strokeTexture (fromMaybe (SC (SomeColor (black :: Colour Double))) s) (realToFrac o) stroke restore -- Add a path to the Canvas context, without stroking or filling it.-canvasPath :: Path R2 -> RenderM ()+canvasPath :: Path V2 Double -> RenderM () canvasPath (Path trs) = do newPath F.mapM_ renderTrail trs@@ -399,19 +384,16 @@ uncurry moveTo p renderC tr -instance Renderable Text Canvas where- render _ (Text tt tn al str) = C $ do- isLocal <- fromMaybe True <$> getStyleAttrib getFontSizeIsLocal+instance Renderable (Text Double) Canvas where+ render _ (Text tr al str) = C $ do tf <- fromMaybe "Calibri" <$> getStyleAttrib getFont- sz <- fromMaybe 12 <$> getStyleAttrib (fromOutput . getFontSize)+ sz <- fromMaybe 12 <$> getStyleAttrib 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+ let fSize = avgScale tr * sz fnt = showFontJS fw slant fSize tf vAlign = case al of BaselineText -> BC.AlphabeticBaseline@@ -429,12 +411,12 @@ liftC $ BC.textBaseline vAlign liftC $ BC.textAlign hAlign liftC $ BC.font fnt- fillTexture tx o- canvasTransform (tn <> reflectionY)+ fillTexture tx (realToFrac o)+ canvasTransform (tr <> reflectionY) liftC $ BC.fillText (T.pack str, 0, 0) restore -instance Renderable (DImage External) Canvas where+instance Renderable (DImage Double External) Canvas where render _ (DImage path w h tr) = C $ do let ImageRef file = path save@@ -443,7 +425,7 @@ liftC $ BC.drawImage (img, [fromIntegral (-w) / 2, fromIntegral (-h) / 2, fromIntegral w, fromIntegral h]) restore -renderCanvas :: Int -> SizeSpec2D -> Diagram Canvas R2 -> IO ()+renderCanvas :: Int -> SizeSpec V2 Double -> QDiagram Canvas V2 Double Any -> 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
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -49,7 +49,7 @@ ----------------------------------------------------------------------------- module Diagrams.Backend.Canvas.CmdLine- ( + ( -- * General form of @main@ -- $mainWith mainWith@@ -61,16 +61,16 @@ , 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 Diagrams.Backend.Canvas+import Diagrams.Backend.CmdLine hiding (height, width)+import Diagrams.Prelude hiding (height, option, value, width,+ (<>))+import qualified Graphics.Blank as BC -import Data.Data-import Control.Lens (makeLenses, (^.))-import Options.Applicative+import Data.Data+import Options.Applicative -data DiaOpts = DiaOpts +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.@@ -89,41 +89,41 @@ <> metavar "HEIGHT" <> help "Desired HEIGHT of the output image") <*> option auto- (long "port" <> short 'p' + (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 :: QDiagram Canvas V2 Double Any -> 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 ()+instance Mainable (QDiagram Canvas V2 Double Any) where+ type MainOpts (QDiagram Canvas V2 Double Any) = DiaOpts++ mainRender = canvasRender++canvasRender :: DiaOpts -> QDiagram Canvas V2 Double Any -> 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+canvasDia :: DiaOpts -> QDiagram Canvas V2 Double Any -> BC.DeviceContext -> IO ()+canvasDia opts d context = BC.send context $- renderDia - Canvas - (CanvasOptions - (mkSizeSpec - (fromIntegral <$> opts^.width) - (fromIntegral <$> opts^.height))) + renderDia+ Canvas+ (CanvasOptions+ (fromIntegral <$> mkSizeSpec2D+ (opts^.width)+ (opts^.height))) d -multiMain :: [(String, Diagram Canvas R2)] -> IO ()+multiMain :: [(String, QDiagram Canvas V2 Double Any)] -> IO () multiMain = mainWith -instance Mainable [(String, Diagram Canvas R2)] where- type MainOpts [(String, Diagram Canvas R2)] = - (MainOpts (Diagram Canvas R2), DiagramMultiOpts)+instance Mainable [(String, QDiagram Canvas V2 Double Any)] where+ type MainOpts [(String, QDiagram Canvas V2 Double Any)] =+ (MainOpts (QDiagram Canvas V2 Double Any), DiagramMultiOpts) mainRender = defaultMultiMainRender