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