diagrams-svg 1.1.0.5 → 1.3
raw patch · 8 files changed
+892/−750 lines, 8 filesdep +lucid-svgdep +optparse-applicativedep +textdep −blaze-markupdep −blaze-svgdep −unixdep ~basedep ~diagrams-coredep ~diagrams-lib
Dependencies added: lucid-svg, optparse-applicative, text
Dependencies removed: blaze-markup, blaze-svg, unix, vector-space
Dependency ranges changed: base, diagrams-core, diagrams-lib, monoid-extras
Files
- CHANGELOG.md +365/−0
- CHANGES.markdown +0/−176
- LICENSE +2/−0
- README.md +4/−1
- diagrams-svg.cabal +19/−22
- src/Diagrams/Backend/SVG.hs +225/−218
- src/Diagrams/Backend/SVG/CmdLine.hs +44/−121
- src/Graphics/Rendering/SVG.hs +233/−212
+ CHANGELOG.md view
@@ -0,0 +1,365 @@+# Change Log++## [v1.3](https://github.com/diagrams/diagrams-svg/tree/v1.3) (2015-04-19)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.4...v1.1.0.5)++**New features**++- User settable ID prefixes++- Support opacity group++- Fix clipping bug (Issue #70)++**Internal Changes**++- Switch rendering engine from `blaze-svg` to `lucid-svg`++- Use `fsnotify` for looping++- Add defs tags for clips and gradients++**Implemented enhancements:**++- Put `clip path`, `gradients`, etc in defs tag. [\#73](https://github.com/diagrams/diagrams-svg/issues/73)++**Fixed bugs:**++- Font size not applied properly in composite diagram [\#66](https://github.com/diagrams/diagrams-svg/issues/66)++- clipping broken [\#70](https://github.com/diagrams/diagrams-svg/issues/70)++**Merged pull requests:**++- State [\#74](https://github.com/diagrams/diagrams-svg/pull/74) ([cchalmers](https://github.com/cchalmers))++- Bump base upper bound [\#72](https://github.com/diagrams/diagrams-svg/pull/72) ([bgamari](https://github.com/bgamari))++- Allow user to set ID prefixes [\#71](https://github.com/diagrams/diagrams-svg/pull/71) ([mightybyte](https://github.com/mightybyte))++- Lucid [\#69](https://github.com/diagrams/diagrams-svg/pull/69) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Use fsnotify for looping, via diagrams-lib [\#67](https://github.com/diagrams/diagrams-svg/pull/67) ([bergey](https://github.com/bergey))++## [v1.1.0.5](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.5) (2015-04-03)++- allow `lens-4.9`++- allow `vector-space-0.10`++- allow `blaze-markup-0.7`++## [v1.1.0.4](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.4) (2015-01-13)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.3...v1.1.0.4)++## [v1.1.0.3](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.3) (2014-12-07)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.2...v1.1.0.3)++## [v1.1.0.2](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.2) (2014-11-17)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.1...v1.1.0.2)++**Fixed bugs:**++- Font scaling uses "em" units. [\#30](https://github.com/diagrams/diagrams-svg/issues/30)++**Merged pull requests:**++- Bump lens upper version bounds [\#65](https://github.com/diagrams/diagrams-svg/pull/65) ([RyanGlScott](https://github.com/RyanGlScott))++- New stuff [\#63](https://github.com/diagrams/diagrams-svg/pull/63) ([cchalmers](https://github.com/cchalmers))++- Allows us to write `Diagram B` instead of `Diagram B V2 Double/Float/Whatever` in diagrams programs [\#62](https://github.com/diagrams/diagrams-svg/pull/62) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Linear [\#61](https://github.com/diagrams/diagrams-svg/pull/61) ([cchalmers](https://github.com/cchalmers))++## [v1.1.0.1](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.1) (2014-08-22)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1...v1.1.0.1)++**Closed issues:**++- Embedding JPEG images without repacking [\#57](https://github.com/diagrams/diagrams-svg/issues/57)++**Merged pull requests:**++- Enable compilation with GHC HEAD \(v7.9\) [\#60](https://github.com/diagrams/diagrams-svg/pull/60) ([ggreif](https://github.com/ggreif))++- Add loadImageSVG to support JPEG-images without repacking via Native DImages [\#58](https://github.com/diagrams/diagrams-svg/pull/58) ([taruti](https://github.com/taruti))++- Allow svg output file to be pretty printed [\#56](https://github.com/diagrams/diagrams-svg/pull/56) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++## [v1.1](https://github.com/diagrams/diagrams-svg/tree/v1.1) (2014-06-02)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.2.1...v1.1)++**New features**++- Support for radial and linear gradients.++- Support for embedded images in `.png` format.++**New instances**++- `Renderable` instances for `DImage Embedded`.++**API changes**++- Updates to work with `Measure` units.++- Substantial refactoring of `Backend` instance to support changes in+ `Diagrams.Core`.++**Dependency/version changes**++- New dependencies: `base64-bytestring` and `JuicyPixels`.++- Allow `lens-4.2`++- Allow `mtl-2.2`++**Closed issues:**++- Support hyperlinks [\#48](https://github.com/diagrams/diagrams-svg/issues/48)++- Line width not handled properly by some browsers [\#33](https://github.com/diagrams/diagrams-svg/issues/33)++- implement image embedding [\#11](https://github.com/diagrams/diagrams-svg/issues/11)++**Merged pull requests:**++- Embedded images - png working [\#54](https://github.com/diagrams/diagrams-svg/pull/54) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- fix text scaling [\#53](https://github.com/diagrams/diagrams-svg/pull/53) ([byorgey](https://github.com/byorgey))++- Updates to work with `Backend` redesign [\#51](https://github.com/diagrams/diagrams-svg/pull/51) ([byorgey](https://github.com/byorgey))++- Rework of units [\#50](https://github.com/diagrams/diagrams-svg/pull/50) ([byorgey](https://github.com/byorgey))++- Preliminary implementation of Measure [\#46](https://github.com/diagrams/diagrams-svg/pull/46) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Gradient [\#41](https://github.com/diagrams/diagrams-svg/pull/41) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++## [v1.0.2.1](https://github.com/diagrams/diagrams-svg/tree/v1.0.2.1) (2014-03-19)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.2...v1.0.2.1)++## [v1.0.2](https://github.com/diagrams/diagrams-svg/tree/v1.0.2) (2014-03-09)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1.3...v1.0.2)++**New features**++- Support for including hyperlinks.++**Dependency/version changes**++- Allow `diagrams-core-1.1` and `diagrams-lib-1.1`++- Allow `lens-4.0`++**Bug fixes**+++- Use `splitFills` to properly render certain diagrams with mixed+ lines and filled loops. Previously, in certain situations loops that should+ have been filled were not. ([#43](https://github.com/diagrams/diagrams-svg/issues/43))++- Don't emit last segment of a loop if it is linear.++ See [diagrams-cairo#38](http://github.com/diagrams/diagrams-cairo/issues/38). This wasn't actually causing any+ observable problems in the SVG backend output, but this seems a+ better/more robust way to do things in any case.++**Closed issues:**++- SVG backend doesn't fill loops if they occur in the same subtree as a line [\#43](https://github.com/diagrams/diagrams-svg/issues/43)++**Merged pull requests:**++- Hyperlinks [\#49](https://github.com/diagrams/diagrams-svg/pull/49) ([tdox](https://github.com/tdox))++- stop using ignoreFill; use splitFills instead. Fixes \#43. [\#47](https://github.com/diagrams/diagrams-svg/pull/47) ([byorgey](https://github.com/byorgey))++## [v1.0.1.3](https://github.com/diagrams/diagrams-svg/tree/v1.0.1.3) (2014-02-06)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1.2...v1.0.1.3)++## [v1.0.1.2](https://github.com/diagrams/diagrams-svg/tree/v1.0.1.2) (2014-02-04)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1.1...v1.0.1.2)++## [v1.0.1.1](https://github.com/diagrams/diagrams-svg/tree/v1.0.1.1) (2014-01-30)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1...v1.0.1.1)++## [v1.0.1](https://github.com/diagrams/diagrams-svg/tree/v1.0.1) (2014-01-26)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0...v1.0.1)++**Merged pull requests:**++- Add Hashable instance for Options SVG R2 [\#45](https://github.com/diagrams/diagrams-svg/pull/45) ([byorgey](https://github.com/byorgey))++## [v1.0](https://github.com/diagrams/diagrams-svg/tree/v1.0) (2013-11-25)++According to the PVP, these changes should require a major version+bump. However, a major version bump would be quite annoying and I+don't expect these instance changes to affect anyone (the changes+were made for internal reasons). Please yell if it does affect+you.++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.8.0.2...v1.0)++**Fixed bugs:**++- SVG backend fills lines again [\#42](https://github.com/diagrams/diagrams-svg/issues/42)++## [v0.8.0.2](https://github.com/diagrams/diagrams-svg/tree/v0.8.0.2) (2013-10-26)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.8.0.1...v0.8.0.2)++**Closed issues:**++- Text alignment support [\#17](https://github.com/diagrams/diagrams-svg/issues/17)++- Add a workaround for the Chrome stroke-width 0 bug [\#3](https://github.com/diagrams/diagrams-svg/issues/3)++**Merged pull requests:**++- Lens [\#40](https://github.com/diagrams/diagrams-svg/pull/40) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Updating information about 'Options SVG' [\#39](https://github.com/diagrams/diagrams-svg/pull/39) ([co-dan](https://github.com/co-dan))++## [v0.8.0.1](https://github.com/diagrams/diagrams-svg/tree/v0.8.0.1) (2013-09-11)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.8...v0.8.0.1)++## [v0.8](https://github.com/diagrams/diagrams-svg/tree/v0.8) (2013-09-10)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.7...v0.8)++**New features**++- Extra SVG definitions, to be inserted in the output, may be+ passed as an argument++- Support for new miter limit attribute++- Approximate text alignment++**Bug fixes**++- Stacking multiple clip regions now works properly++**Merged pull requests:**++- Font embedding changes [\#38](https://github.com/diagrams/diagrams-svg/pull/38) ([jbracker](https://github.com/jbracker))++- Added approximation of text alignment. Better then nothing... [\#36](https://github.com/diagrams/diagrams-svg/pull/36) ([jbracker](https://github.com/jbracker))++## [v0.7](https://github.com/diagrams/diagrams-svg/tree/v0.7) (2013-08-09)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.6.0.1...v0.7)++**New features**++- New `renderToSVG` convenience function++- Vastly improved Haddock documentation++**New instances**++- `Show` instance for `Options SVG R2`++**Dependency/version changes**++- allow `base-4.7` and `unix-2.7`++- Upgrade to `monoid-extras-0.3`++**Implemented enhancements:**++- Improve Haddock documentation [\#27](https://github.com/diagrams/diagrams-svg/issues/27)++**Fixed bugs:**++- Lines should not be filled [\#35](https://github.com/diagrams/diagrams-svg/issues/35)++**Closed issues:**++- diagrams-svg.cabal out of sync with core and lib [\#34](https://github.com/diagrams/diagrams-svg/issues/34)++- Add function of type FilePath -\> SizeSpec2D -\> Diagram -\> IO \(\) [\#28](https://github.com/diagrams/diagrams-svg/issues/28)++**Merged pull requests:**++- General SVG backend cleanup, additional documentation, and new API function [\#29](https://github.com/diagrams/diagrams-svg/pull/29) ([byorgey](https://github.com/byorgey))++## [v0.6.0.1](https://github.com/diagrams/diagrams-svg/tree/v0.6.0.1) (2012-12-14)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.6...v0.6.0.1)++## [v0.6](https://github.com/diagrams/diagrams-svg/tree/v0.6) (2012-12-12)++First "officially supported" release.++Features still not implemented:++- text alignment++- inline images++As of this release everything else Should Work (tm).++**Closed issues:**++- Line width does not follow specification? [\#24](https://github.com/diagrams/diagrams-svg/issues/24)++- diagrams-svg doesn't build under directory-1.2 \(and hence GHC-7.6\) [\#20](https://github.com/diagrams/diagrams-svg/issues/20)++- Freezing does not appear to work with the SVG backend [\#19](https://github.com/diagrams/diagrams-svg/issues/19)++- Font family support [\#18](https://github.com/diagrams/diagrams-svg/issues/18)++- Fill color needs to be explicitly specified for text nodes [\#15](https://github.com/diagrams/diagrams-svg/issues/15)++- Implement clipping [\#14](https://github.com/diagrams/diagrams-svg/issues/14)++- Add README, documentation and generate documentation on Hackage [\#13](https://github.com/diagrams/diagrams-svg/issues/13)++- implement text attributes [\#10](https://github.com/diagrams/diagrams-svg/issues/10)++- implement text rendering [\#9](https://github.com/diagrams/diagrams-svg/issues/9)++- implement line cap [\#8](https://github.com/diagrams/diagrams-svg/issues/8)++- implement line dashing [\#7](https://github.com/diagrams/diagrams-svg/issues/7)++- Implement line join attribute [\#6](https://github.com/diagrams/diagrams-svg/issues/6)++- Implement opacity [\#5](https://github.com/diagrams/diagrams-svg/issues/5)++- Implement fill rule [\#4](https://github.com/diagrams/diagrams-svg/issues/4)++- Switch to using blaze-svg combinators [\#2](https://github.com/diagrams/diagrams-svg/issues/2)++- Create a new branch for using blaze-svg [\#1](https://github.com/diagrams/diagrams-svg/issues/1)++**Merged pull requests:**++- Fix for clipping with freeze support. [\#26](https://github.com/diagrams/diagrams-svg/pull/26) ([fryguybob](https://github.com/fryguybob))++- Apply frozen transformations with <g\> element. [\#25](https://github.com/diagrams/diagrams-svg/pull/25) ([cmears](https://github.com/cmears))++- ghc-7.6 [\#23](https://github.com/diagrams/diagrams-svg/pull/23) ([michaelt](https://github.com/michaelt))++- Increase cmdargs upper bound to < 0.10 [\#16](https://github.com/diagrams/diagrams-svg/pull/16) ([byorgey](https://github.com/byorgey))++- Line join + cap [\#12](https://github.com/diagrams/diagrams-svg/pull/12) ([byorgey](https://github.com/byorgey))+++\* *This Change Log was automatically generated by (and hand edited) [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)*
− CHANGES.markdown
@@ -1,176 +0,0 @@-1.1.0.5 (2 April 2015)------------------------- - allow `lens-4.9`- - allow `vector-space-0.10`- - allow `blaze-markup-0.7`--1.1.0.4 (13 Jan 2015)------------------------- Allow `vector-space-0.9`-- Allow `lens-4.7`--1.1.0.3 (07 December 2014)------------------------------ Allow `JuicyPixels-3.2`--1.1.0.2 (17 November 2014)------------------------------ Allow `lens-4.6`--1.1.0.1 (22 August 2014)---------------------------- Allow `lens-4.4`--1.1 (27 May 2014)--------------------* **New features**-- - Support for radial and linear gradients.-- - Support for embedded images in `.png` format.--* **New instances**-- - `Renderable` instances for `DImage Embedded`.--* **API changes**-- - Updates to work with `Measure` units.-- - Substantial refactoring of `Backend` instance to support changes in- `Diagrams.Core`.--* **Dependency/version changes**-- - New dependencies: `base64-bytestring` and `JuicyPixels`.- - Allow `lens-4.2`- - Allow `mtl-2.2`--1.0.2.1 (19 March 2014)------------------------- - Allow `lens-4.1`--1.0.2 (8 March 2014)-----------------------* **New features**-- - Support for including hyperlinks.--* **Dependency/version changes**-- - Allow `diagrams-core-1.1` and `diagrams-lib-1.1`- - Allow `lens-4.0`--* **Bug fixes**--- - Use `splitFills` to properly render certain diagrams with mixed- lines and filled loops. Previously, in certain situations loops that should- have been filled were not. ([#43](https://github.com/diagrams/diagrams-svg/issues/43))-- - Don't emit last segment of a loop if it is linear.-- See [diagrams-cairo#38](http://github.com/diagrams/diagrams-cairo/issues/38). This wasn't actually causing any- observable problems in the SVG backend output, but this seems a- better/more robust way to do things in any case.--1.0.1.3 (6 February 2014)---------------------------- - require diagrams-lib >= 1.0.1 (for Hashable SizeSpec2D instance)--1.0.1.2 (4 February 2014)---------------------------- - Allow `blaze-markup-0.6`--1.0.1.1 (30 January 2014)---------------------------- - Work around a bug in GHC 7.4.2, which chokes when deriving Generic- instances for associated data types.--1.0.1 (26 January 2014)-------------------------- - Add `Hashable (Options SVG R2)` instance- - Remove `Show (Options SVG R2)` instance-- According to the PVP, these changes should require a major version- bump. However, a major version bump would be quite annoying and I- don't expect these instance changes to affect anyone (the changes- were made for internal reasons). Please yell if it does affect- you.--1.0 (24 November 2013)------------------------- - Re-implement via new backend `RTree` interface, leading to- smaller output files.- - Use new command-line interface from `diagrams-lib`.- - Export `B` as an alias for `SVG` token--0.8.0.2 (26 October 2013)---------------------------- - Documentation improvements--0.8.0.1: 11 September 2013----------------------------- - require diagrams-lib-0.7.1--0.8: 10 September 2013 [BROKEN]----------------------------------* **New features**-- - Extra SVG definitions, to be inserted in the output, may be- passed as an argument- - Support for new miter limit attribute- - Approximate text alignment--* **Bug fixes**-- - Stacking multiple clip regions now works properly--0.7: 9 August 2013---------------------* **New features**-- - New `renderToSVG` convenience function- - Vastly improved Haddock documentation--* **New instances**-- - `Show` instance for `Options SVG R2`--* **Dependency/version changes**- - allow `base-4.7` and `unix-2.7`- - Upgrade to `monoid-extras-0.3`--0.6.0.1: 14 December 2012----------------------------* Fix link to README on Hackage page--0.6: 11 December 2012------------------------First "officially supported" release.--Features still not implemented:--- text alignment-- inline images--As of this release everything else Should Work (tm).
LICENSE view
@@ -1,7 +1,9 @@ Copyright 2011-2014 diagrams-svg team: + Doug Beardsley <mightybyte@gmail.com> Daniel Bergey <bergey@alum.mit.edu> Jan Bracker <jan.bracker@googlemail.com>+ Christopher Chalmers <c.chalmers@me.com> Daniil Frumin <difrumin@gmail.com> Deepak Jois <deepak.jois@gmail.com> Felipe Lessa <felipe.lessa@gmail.com>
README.md view
@@ -1,5 +1,7 @@-[](http://travis-ci.org/diagrams/diagrams-svg)+diagrams-svg [](https://hackage.haskell.org/package/diagrams-svg) [](http://travis-ci.org/diagrams/diagrams-svg)+------------ + _diagrams-svg_ is a an SVG backend for [diagrams]. Diagrams is a powerful, flexible, declarative domain-specific language for creating vector graphics, using the [Haskell programming language][haskell].@@ -55,6 +57,7 @@ -l,--loop Run in a self-recompiling loop -s,--src ARG Source file to watch -i,--interval INTERVAL When running in a loop, check for changes every INTERVAL seconds.+ -p,--pretty Pretty print the SVG output ``` You _must_ pass an output file name with a `.svg` extension to generate the SVG
diagrams-svg.cabal view
@@ -1,10 +1,10 @@ Name: diagrams-svg-Version: 1.1.0.5+Version: 1.3 Synopsis: SVG backend for diagrams drawing EDSL. Homepage: http://projects.haskell.org/diagrams/ License: BSD3 License-file: LICENSE-Extra-source-files: README.md, CHANGES.markdown+Extra-source-files: README.md, CHANGELOG.md Author: Felipe Lessa, Deepak Jois Maintainer: diagrams-discuss@googlegroups.com Bug-reports: http://github.com/diagrams/diagrams-svg/issues@@ -12,10 +12,10 @@ Category: Graphics Build-type: Simple Cabal-version: >=1.10-Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1+Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL to SVG- files. It uses @blaze-svg@ to be a fast, native+ files. It uses @lucid-svg@ to be a native Haskell backend, making it suitable for use on any platform. .@@ -40,32 +40,29 @@ Diagrams.Backend.SVG.CmdLine Other-modules: Graphics.Rendering.SVG Hs-source-dirs: src- Build-depends: base >= 4.3 && < 4.8+ Build-depends: base >= 4.3 && < 4.9 , old-time , process , directory , filepath- , mtl >= 1 && < 2.3- , bytestring >= 0.9 && < 1.0- , base64-bytestring >= 1 && < 1.1- , vector-space >= 0.7 && < 0.11+ , mtl >= 1 && < 2.3+ , bytestring >= 0.9 && < 1.0+ , base64-bytestring >= 1 && < 1.1 , colour- , diagrams-core >= 1.2 && < 1.3- , diagrams-lib >= 1.2 && < 1.3- , monoid-extras >= 0.3 && < 0.4- , blaze-svg >= 0.3.3- , blaze-markup >= 0.5 && < 0.8- , JuicyPixels >= 3.1.5 && < 3.3- , split >= 0.1.2 && < 0.3+ , diagrams-core >= 1.3 && < 1.4+ , diagrams-lib >= 1.3 && < 1.4+ , monoid-extras >= 0.3 && < 0.5+ , lucid-svg >= 0.4.0.3 && < 0.5+ , text >= 0.11 && < 1.3+ , JuicyPixels >= 3.1.5 && < 3.3+ , split >= 0.1.2 && < 0.3 , time- , containers >= 0.3 && < 0.6- , lens >= 4.0 && < 4.10- , hashable >= 1.1 && < 1.3+ , containers >= 0.3 && < 0.6+ , lens >= 4.0 && < 4.10+ , hashable >= 1.1 && < 1.3+ , optparse-applicative >= 0.10 && < 0.12 if impl(ghc < 7.6) build-depends: ghc-prim- if !os(windows)- cpp-options: -DCMDLINELOOP- Build-depends: unix >= 2.4 && < 2.8 Ghc-options: -Wall
src/Diagrams/Backend/SVG.hs view
@@ -1,19 +1,26 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+ -- UndecidableInstances needed for ghc < 707 ---------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.SVG--- Copyright : (c) 2011-2012 diagrams-svg team (see LICENSE)+-- Copyright : (c) 2011-2015 diagrams-svg team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com --@@ -26,11 +33,13 @@ -- * You can use the "Diagrams.Backend.SVG.CmdLine" module to create -- standalone executables which output SVG images when invoked. ----- * You can use the 'renderSVG' function provided by this module,--- which gives you more flexible programmatic control over when and--- how images are output (making it easy to, for example, write a+-- * You can use the 'renderSVG' or 'renderPretty' functions provided by+-- this module, which give you more flexible programmatic control over when+-- and how images are output (making it easy to, for example, write a -- single program that outputs multiple images, or one that outputs--- images dynamically based on user input, and so on).+-- images dynamically based on user input, and so on). The only+-- difference between the two functions is that 'renderPretty', pretty+-- prints the SVG output. -- -- * For the most flexibility (/e.g./ if you want access to the -- resulting SVG value directly in memory without writing it to@@ -38,308 +47,306 @@ -- 'Diagrams.Core.Types.Backend' instance for @SVG@. In particular, -- 'Diagrams.Core.Types.renderDia' has the generic type ----- > renderDia :: b -> Options b v -> QDiagram b v m -> Result b v+-- > renderDia :: b -> Options b v n -> QDiagram b v n m -> Result b v n -- -- (omitting a few type class constraints). @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+-- backend type, @v@ the vector space, @n@ the numerical field, 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 ~ SVG@ and @v ~ R2@, we have+-- particular backend. For @b ~ SVG@, @v ~ V2@, we have ----- > data Options SVG R2 = SVGOptions--- > { size :: SizeSpec2D -- ^ The requested size.--- > , svgDefinitions :: Maybe S.Svg--- > -- ^ Custom definitions that will be added to the @defs@--- > -- section of the output.--- > }+-- > data Options SVG V2 n = SVGOptions+-- > { _size :: SizeSpec V2 n -- ^ The requested size.+-- > , _svgDefinitions :: [Attribute]+-- > -- ^ Custom definitions that will be added to the @defs@+-- > -- section of the output.+-- > , _idPrefix :: T.Text+-- > } -- -- @--- data family Render SVG R2 = R 'SvgRenderM'+-- data family Render SVG V2 n = R 'SvgRenderM n' -- @ -- -- @--- type family Result SVG R2 = 'Text.Blaze.Svg11.Svg'+-- type family Result SVG V2 n = 'Graphics.Rendering.SVG.SvgM' -- @ -- -- So the type of 'renderDia' resolves to -- -- @--- renderDia :: SVG -> Options SVG R2 -> QDiagram SVG R2 m -> 'Text.Blaze.Svg11.Svg'+-- renderDia :: SVG -> Options SVG V2 n -> QDiagram SVG V2 n m -> 'Graphics.Rendering.SVG.SvgM' -- @ ----- which you could call like @renderDia SVG (SVGOptions (Width 250))--- myDiagram@. (In some situations GHC may not be able to infer the--- type @m@, in which case you can use a type annotation to specify--- it; it may be useful to simply use the type synonym @Diagram SVG--- R2 = QDiagram SVG R2 Any@.) This returns an--- 'Text.Blaze.Svg11.Svg' value, which you can, /e.g./ render to a--- 'ByteString' using 'Text.Blaze.Svg.Renderer.Utf8.renderSvg'.+-- which you could call like @renderDia SVG (SVGOptions (mkWidth 250)+-- [] "") myDiagram@ (if you have the 'OverloadedStrings' extension+-- enabled; otherwise you can use 'Text.pack ""'). (In some+-- situations GHC may not be able to infer the type @m@, in which case+-- you can use a type annotation to specify it; it may be useful to+-- simply use the type synonym @Diagram SVG = QDiagram SVG V2 Double+-- Any@.) This returns an 'Graphics.Rendering.SVG.SvgM' value, which+-- you can, /e.g./ render to a 'ByteString' using 'Lucid.Svg.renderBS'+-- from the 'lucid' package. -- ----------------------------------------------------------------------------- module Diagrams.Backend.SVG ( SVG(..) -- rendering token , B- , Options(..), size, svgDefinitions -- for rendering options specific to SVG+ , Options(..), sizeSpec, svgDefinitions, idPrefix -- for rendering options specific to SVG+ , SVGFloat , renderSVG+ , renderSVG'+ , renderPretty+ , renderPretty'+ , loadImageSVG ) where --- for testing-import Data.Foldable (foldMap)+-- from JuicyPixels+import Codec.Picture+import Codec.Picture.Types (dynamicMap)++#if __GLASGOW_HASKELL__ < 710+import Data.Foldable as F (foldMap)+#endif+import qualified Data.Text as T+import Data.Text.Lazy.IO as LT import Data.Tree+import System.FilePath -- from base import Control.Monad.State+import Data.Char import Data.Typeable-import GHC.Generics (Generic) -- from hashable-import Data.Hashable (Hashable (..))+import Data.Hashable (Hashable (..)) -- from bytestring-import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString as SBS+import qualified Data.ByteString.Lazy as BS -- from lens-import Control.Lens hiding (transform, ( # ))+import Control.Lens hiding (transform, ( # )) -- from diagrams-core import Diagrams.Core.Compile-import Diagrams.Core.Types (Annotation (..))+import Diagrams.Core.Types (Annotation (..)) -- from diagrams-lib-import Diagrams.Prelude hiding (view)-import Diagrams.TwoD.Adjust (adjustDia2D)-import Diagrams.TwoD.Attributes (splitTextureFills)-import Diagrams.TwoD.Path (Clip (Clip))-import Diagrams.TwoD.Size (sizePair)+import Diagrams.Prelude hiding (Attribute, size, view)+import Diagrams.TwoD.Adjust (adjustDia2D)+import Diagrams.TwoD.Attributes (splitTextureFills)+import Diagrams.TwoD.Path (Clip (Clip)) import Diagrams.TwoD.Text --- from blaze-svg-import Text.Blaze.Internal (ChoiceString (..), MarkupM (..),- StaticString (..))-import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)-import Text.Blaze.Svg11 ((!))-import qualified Text.Blaze.Svg11 as S-import Text.Blaze.Svg11.Attributes (xlinkHref)+-- from lucid-svg+import Lucid.Svg -- from this package-import qualified Graphics.Rendering.SVG as R+import Graphics.Rendering.SVG (SVGFloat, SvgM)+import qualified Graphics.Rendering.SVG as R -- | @SVG@ is simply a token used to identify this rendering backend -- (to aid type inference). data SVG = SVG- deriving (Show, Typeable)+ deriving (Show, Typeable) type B = SVG -data SvgRenderState = SvgRenderState { _clipPathId :: Int- , _fillGradId :: Int- , _lineGradId :: Int- , _isLocalText :: Bool }+type instance V SVG = V2+type instance N SVG = Double +data SvgRenderState n = SvgRenderState+ { _clipPathId :: Int+ , _fillGradId :: Int+ , _lineGradId :: Int+ , _style :: Style V2 n+ , __pre :: T.Text+ }+ makeLenses ''SvgRenderState -- Fill gradients ids are even, line gradient ids are odd.-initialSvgRenderState :: SvgRenderState-initialSvgRenderState = SvgRenderState 0 0 1 True+initialSvgRenderState :: SVGFloat n => T.Text -> SvgRenderState n+initialSvgRenderState = SvgRenderState 0 0 1 (mempty # recommendFillColor transparent) -- | Monad to keep track of state when rendering an SVG. -- Currently just keeps a monotonically increasing counter -- for assiging a unique clip path ID.-type SvgRenderM = State SvgRenderState S.Svg+type SvgRenderM n = State (SvgRenderState n) SvgM -instance Monoid (Render SVG R2) where- mempty = R $ return mempty- (R r1) `mappend` (R r2_) =- R $ do- svg1 <- r1- svg2 <- r2_- return (svg1 `mappend` svg2)+instance SVGFloat n => Monoid (Render SVG V2 n) where+ mempty = R $ return mempty+ R r1 `mappend` R r2_ = R $ do+ svg1 <- r1+ svg2 <- r2_+ return (svg1 `mappend` svg2) -- Handle clip attributes.-renderSvgWithClipping :: S.Svg -- ^ Input SVG- -> Style v -- ^ Styles- -> SvgRenderM -- ^ Resulting svg-renderSvgWithClipping svg s =- case (op Clip <$> getAttr s) of- Nothing -> return $ svg+--+renderSvgWithClipping :: forall n. SVGFloat n+ => T.Text+ -> SvgM -- ^ Input SVG+ -> Style V2 n -- ^ Styles+ -> SvgRenderM n -- ^ Resulting svg++renderSvgWithClipping prefix svg s =+ case op Clip <$> getAttr s of+ Nothing -> return svg Just paths -> renderClips paths where- renderClips :: [Path R2] -> SvgRenderM- renderClips [] = return $ svg+ renderClips :: SVGFloat n => [Path V2 n] -> SvgRenderM n+ renderClips [] = return svg renderClips (p:ps) = do clipPathId += 1- id_ <- use clipPathId- R.renderClip p id_ <$> renderClips ps+ ident <- use clipPathId+ R.renderClip p prefix ident <$> renderClips ps -- | Create a new texture defs svg element using the style and the current -- id number, then increment the gradient id number.-fillTextureDefs :: Style v -> SvgRenderM+fillTextureDefs :: SVGFloat n => Style v n -> SvgRenderM n fillTextureDefs s = do- id_ <- use fillGradId+ ident <- use fillGradId fillGradId += 2 -- always even- return $ R.renderFillTextureDefs id_ s+ return $ R.renderFillTextureDefs ident s -lineTextureDefs :: Style v -> SvgRenderM+lineTextureDefs :: SVGFloat n => Style v n -> SvgRenderM n lineTextureDefs s = do- id_ <- use lineGradId+ ident <- use lineGradId lineGradId += 2 -- always odd- return $ R.renderLineTextureDefs id_ s+ return $ R.renderLineTextureDefs ident s -instance Backend SVG R2 where- data Render SVG R2 = R SvgRenderM- type Result SVG R2 = S.Svg- data Options SVG R2 = SVGOptions- { _size :: SizeSpec2D -- ^ The requested size.- , _svgDefinitions :: Maybe S.Svg+instance SVGFloat n => Backend SVG V2 n where+ data Render SVG V2 n = R (SvgRenderM n)+ type Result SVG V2 n = SvgM+ data Options SVG V2 n = SVGOptions+ { _size :: SizeSpec V2 n -- ^ The requested size.+ , _svgDefinitions :: [Attribute] -- ^ Custom definitions that will be added to the @defs@ -- section of the output.- }+ , _idPrefix :: T.Text+ } - renderRTree _ opts rt = evalState svgOutput initialSvgRenderState+ renderRTree _ opts rt = evalState svgOutput (initialSvgRenderState $ opts ^.idPrefix) where svgOutput = do- let R r = toRender rt- (w,h) = sizePair (opts^.size)+ let R r = rtree (splitTextureFills rt)+ V2 w h = specToSize 100 (opts^.sizeSpec) svg <- r- return $ R.svgHeader w h (opts^.svgDefinitions) $ svg+ return $ R.svgHeader w h (opts^.svgDefinitions) svg - adjustDia c opts d = adjustDia2D size c opts (d # reflectY)+ adjustDia c opts d = adjustDia2D sizeSpec c opts (d # reflectY) -toRender :: RTree SVG R2 Annotation -> Render SVG R2-toRender = fromRTree- . Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))- . (:[])- . splitTextureFills- where- fromRTree (Node (RAnnot (Href uri)) rs)- = R $ do- let R r = foldMap fromRTree rs- svg <- r- return $ (S.a ! xlinkHref (S.toValue uri)) svg- fromRTree (Node (RPrim p) _) = render SVG p- fromRTree (Node (RStyle sty) ts)- = R $ do- let R r = foldMap fromRTree ts+rtree :: SVGFloat n => RTree SVG V2 n Annotation -> Render SVG V2 n+rtree (Node n rs) = case n of+ RPrim p -> render SVG p+ RStyle sty' -> R $ do+ -- mappend new state and retrieve old state+ sty <- style <<<>= sty'+ -- render contents and return state to old state+ r <* (style .= sty)+ RAnnot (OpacityGroup o) -> R $ g_ [opacity_ $ toText o] <$> r+ RAnnot (Href uri) -> R $ a_ [xlinkHref_ $ toText uri] <$> r+ _ -> R r+ where+ R r = foldMap rtree rs - -- save current setting for local text- oldIsLocal <- use isLocalText- -- check if this style speficies a font size in Local units- case getFontSizeIsLocal <$> getAttr sty of- Nothing -> return ()- Just isLocal -> isLocalText .= isLocal- -- render subtrees- svg <- r- -- restore the old setting for local text- isLocalText .= oldIsLocal+-- | Lens onto the size of the svg options.+sizeSpec :: SVGFloat n => Lens' (Options SVG V2 n) (SizeSpec V2 n)+sizeSpec f opts = f (_size opts) <&> \s -> opts { _size = s } - idFill <- use fillGradId- idLine <- use lineGradId- clippedSvg <- renderSvgWithClipping svg sty- lineGradDefs <- lineTextureDefs sty- fillGradDefs <- fillTextureDefs sty- let textureDefs = fillGradDefs `mappend` lineGradDefs- return $ (S.g ! R.renderStyles idFill idLine sty)- (textureDefs `mappend` clippedSvg)- fromRTree (Node _ rs) = foldMap fromRTree rs+-- | Lens onto the svg definitions of the svg options.+svgDefinitions :: SVGFloat n => Lens' (Options SVG V2 n) [Attribute]+svgDefinitions f opts =+ f (_svgDefinitions opts) <&> \ds -> opts { _svgDefinitions = ds } -getSize :: Options SVG R2 -> SizeSpec2D-getSize (SVGOptions {_size = s}) = s+-- | Lens onto the idPrefix of the svg options. This is the prefix given+-- to clipping paths to distinguish them from other svg files in the+-- same web page.+idPrefix :: SVGFloat n => Lens' (Options SVG V2 n) T.Text+idPrefix f opts = f (_idPrefix opts) <&> \i -> opts { _idPrefix = i } -setSize :: Options SVG R2 -> SizeSpec2D -> Options SVG R2-setSize o s = o {_size = s}+-- paths --------------------------------------------------------------- -size :: Lens' (Options SVG R2) SizeSpec2D-size = lens getSize setSize+attributedRender :: SVGFloat n => SvgM -> SvgRenderM n+attributedRender svg = do+ SvgRenderState _idClip idFill idLine sty preT <- get+ clippedSvg <- renderSvgWithClipping preT svg sty+ lineGradDefs <- lineTextureDefs sty+ fillGradDefs <- fillTextureDefs sty+ return $ do+ defs_ $ fillGradDefs >> lineGradDefs+ g_ (R.renderStyles idFill idLine sty) clippedSvg -getSVGDefs :: Options SVG R2 -> Maybe S.Svg-getSVGDefs (SVGOptions {_svgDefinitions = d}) = d+instance SVGFloat n => Renderable (Path V2 n) SVG where+ render _ = R . attributedRender . R.renderPath -setSVGDefs :: Options SVG R2 -> Maybe S.Svg -> Options SVG R2-setSVGDefs o d = o {_svgDefinitions = d}+instance SVGFloat n => Renderable (Text n) SVG where+ render _ = R . attributedRender . R.renderText -svgDefinitions :: Lens' (Options SVG R2) (Maybe S.Svg)-svgDefinitions = lens getSVGDefs setSVGDefs+instance SVGFloat n => Renderable (DImage n Embedded) SVG where+ render _ = R . return . R.renderDImageEmb -instance Hashable (Options SVG R2) where- hashWithSalt s (SVGOptions sz defs) =- s `hashWithSalt` sz `hashWithSalt` defs+-- TODO: instance Renderable Image SVG where -instance Hashable StaticString where- hashWithSalt s (StaticString dl bs txt)- = s `hashWithSalt` dl [] `hashWithSalt` bs `hashWithSalt` txt+-- | Render a diagram as an SVG, writing to the specified output file+-- and using the requested size.+renderSVG :: SVGFloat n => FilePath -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO ()+renderSVG outFile spec = renderSVG' outFile (SVGOptions spec [] (mkPrefix outFile)) -deriving instance Generic ChoiceString+-- | Render a diagram as a pretty printed SVG.+renderPretty :: SVGFloat n => FilePath -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO ()+renderPretty outFile spec = renderPretty' outFile (SVGOptions spec [] (mkPrefix outFile)) -instance Hashable ChoiceString+-- Create a prefile using the basename of the output file. Only standard+-- letters are considered.+mkPrefix :: FilePath -> T.Text+mkPrefix = T.filter isAlpha . T.pack . takeBaseName -instance Hashable (MarkupM a) where- hashWithSalt s (Parent w x y z) =- s `hashWithSalt`- (0 :: Int) `hashWithSalt`- w `hashWithSalt`- x `hashWithSalt`- y `hashWithSalt`- z- hashWithSalt s (CustomParent cs m) =- s `hashWithSalt`- (1 :: Int) `hashWithSalt`- cs `hashWithSalt`- m- hashWithSalt s (Leaf s1 s2 s3) =- s `hashWithSalt`- (2 :: Int) `hashWithSalt`- s1 `hashWithSalt`- s2 `hashWithSalt`- s3- hashWithSalt s (CustomLeaf cs b) =- s `hashWithSalt`- (3 :: Int) `hashWithSalt`- cs `hashWithSalt`- b- hashWithSalt s (Content cs) =- s `hashWithSalt`- (4 :: Int) `hashWithSalt`- cs- hashWithSalt s (Append m1 m2) =- s `hashWithSalt`- (5 :: Int) `hashWithSalt`- m1 `hashWithSalt`- m2- hashWithSalt s (AddAttribute s1 s2 s3 m) =- s `hashWithSalt`- (6 :: Int) `hashWithSalt`- s1 `hashWithSalt`- s2 `hashWithSalt`- s3 `hashWithSalt`- m- hashWithSalt s (AddCustomAttribute s1 s2 m) =- s `hashWithSalt`- (7 :: Int) `hashWithSalt`- s1 `hashWithSalt`- s2 `hashWithSalt`- m- hashWithSalt s Empty = s `hashWithSalt` (8 :: Int)+-- | Render a diagram as an SVG, writing to the specified output file+-- and using the backend options. The id prefix is derived from the+-- basename of the output file.+renderSVG' :: SVGFloat n => FilePath -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()+renderSVG' outFile opts = BS.writeFile outFile . renderBS . renderDia SVG opts -instance Renderable (Path R2) SVG where- render _ = R . return . R.renderPath+-- | Render a diagram as a pretty printed SVG to the specified output+-- file and using the backend options. The id prefix is derived from the+-- basename of the output file.+renderPretty' :: SVGFloat n => FilePath -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()+renderPretty' outFile opts = LT.writeFile outFile . prettyText . renderDia SVG opts -instance Renderable Text SVG where- render _ t = R $ do- isLocal <- use isLocalText- return $ R.renderText isLocal t+data Img = Img !Char !BS.ByteString deriving Typeable -instance Renderable (DImage Embedded) SVG where- render _ = R . return . R.renderDImage+-- | Load images (JPG/PNG/...) in a SVG specific way.+loadImageSVG :: SVGFloat n => FilePath -> IO (QDiagram SVG V2 n Any)+loadImageSVG fp = do+ raw <- SBS.readFile fp+ dyn <- eIO $ decodeImage raw+ let dat = BS.fromChunks [raw]+ let pic t d = return $ image (DImage (ImageNative (Img t d))+ (dynamicMap imageWidth dyn)+ (dynamicMap imageHeight dyn) mempty)+ if pngHeader `SBS.isPrefixOf` raw then pic 'P' dat else do+ if jpgHeader `SBS.isPrefixOf` raw then pic 'J' dat else do+ case dyn of+ (ImageYCbCr8 _) -> pic 'J' dat+ _ -> pic 'P' =<< eIO (encodeDynamicPng dyn)+ where pngHeader :: SBS.ByteString+ pngHeader = SBS.pack [137, 80, 78, 71, 13, 10, 26, 10]+ jpgHeader :: SBS.ByteString+ jpgHeader = SBS.pack [0xFF, 0xD8]+ eIO :: Either String a -> IO a+ eIO = either fail return --- TODO: instance Renderable Image SVG where+instance SVGFloat n => Renderable (DImage n (Native Img)) SVG where+ render _ di@(DImage (ImageNative (Img t d)) _ _ _) = R $ do+ mime <- case t of+ 'J' -> return "image/jpeg"+ 'P' -> return "image/png"+ _ -> fail "Unknown mime type while rendering image"+ return $ R.renderDImage di $ R.dataUri mime d --- | Render a diagram as an SVG, writing to the specified output file--- and using the requested size.-renderSVG :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO ()-renderSVG outFile sizeSpec- = BS.writeFile outFile- . renderSvg- . renderDia SVG (SVGOptions sizeSpec Nothing)+instance (Hashable n, SVGFloat n) => Hashable (Options SVG V2 n) where+ hashWithSalt s (SVGOptions sz defs _) = s `hashWithSalt` sz `hashWithSalt` defs
src/Diagrams/Backend/SVG/CmdLine.hs view
@@ -1,8 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.SVG.CmdLine@@ -47,11 +51,11 @@ -- -- For a tutorial on command-line diagram creation see -- <http://projects.haskell.org/diagrams/doc/cmdline.html>.--- +-- ----------------------------------------------------------------------------- module Diagrams.Backend.SVG.CmdLine- ( + ( -- * General form of @main@ -- $mainwith @@ -68,45 +72,15 @@ , B ) where -import Diagrams.Prelude hiding (width, height, interval)-import Diagrams.Backend.SVG-import Diagrams.Backend.CmdLine--import Control.Lens--import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)-import qualified Data.ByteString.Lazy as BS--import Data.List.Split--#ifdef CMDLINELOOP-import Data.Maybe (fromMaybe)-import Control.Monad (when)-import System.Directory (getModificationTime)-import System.Process (runProcess, waitForProcess)-import System.IO (openFile, hClose, IOMode(..),- hSetBuffering, BufferMode(..), stdout)-import System.Exit (ExitCode(..))-import Control.Concurrent (threadDelay)-import qualified Control.Exception as Exc (catch, bracket)-import Control.Exception (SomeException(..))--import System.Environment (getProgName,getArgs)-import System.Posix.Process (executeFile)+import Diagrams.Backend.CmdLine+import Diagrams.Backend.SVG+import Diagrams.Prelude hiding (height, interval, output,+ width) +import Options.Applicative hiding ((<>))+import qualified Options.Applicative as O ((<>)) -# if MIN_VERSION_directory(1,2,0)-import Data.Time.Clock (UTCTime,getCurrentTime)-type ModuleTime = UTCTime-getModuleTime :: IO ModuleTime-getModuleTime = getCurrentTime-#else-import System.Time (ClockTime, getClockTime)-type ModuleTime = ClockTime-getModuleTime :: IO ModuleTime-getModuleTime = getClockTime-#endif-#endif+import Data.List.Split -- $mainwith -- The 'mainWith' method unifies all of the other forms of @main@ and is@@ -117,7 +91,7 @@ -- will produce a program that looks for additional number and color arguments. -- -- > ... definitions ...--- > f :: Int -> Colour Double -> Diagram SVG R2+-- > f :: Int -> Colour Double -> Diagram SVG V2 Double -- > f i c = ... -- > -- > main = mainWith f@@ -125,7 +99,7 @@ -- We can run this program as follows: -- -- > $ ghc --make MyDiagram--- > +-- > -- > # output image.svg built by `f 20 red` -- > $ ./MyDiagram -o image.svg -w 200 20 red @@ -147,7 +121,7 @@ -- @ -- ./Program ----- Usage: ./Program [-w|--width WIDTH] [-h|--height HEIGHT] [-o|--output OUTPUT] [--loop] [-s|--src ARG] [-i|--interval INTERVAL]+-- Usage: ./Program [-w|--width WIDTH] [-h|--height HEIGHT] [-o|--output OUTPUT] [--loop] [-s|--src ARG] [-i|--interval INTERVAL] [-p|--pretty] -- Command-line diagram generation. -- -- Available options:@@ -158,6 +132,7 @@ -- -l,--loop Run in a self-recompiling loop -- -s,--src ARG Source file to watch -- -i,--interval INTERVAL When running in a loop, check for changes every INTERVAL seconds.+-- -p,--pretty Pretty print the SVG output -- @ -- -- For example, a common scenario is@@ -169,36 +144,34 @@ -- $ ./MyDiagram -o image.svg -w 400 -- @ -defaultMain :: Diagram SVG R2 -> IO ()+defaultMain :: SVGFloat n => QDiagram SVG V2 n Any -> IO () defaultMain = mainWith -instance Mainable (Diagram SVG R2) where-#ifdef CMDLINELOOP- type MainOpts (Diagram SVG R2) = (DiagramOpts, DiagramLoopOpts)+newtype PrettyOpt = PrettyOpt {isPretty :: Bool} - mainRender (opts,loopOpts) d = do- chooseRender opts d- when (loopOpts^.loop) (waitForChange Nothing loopOpts)-#else- type MainOpts (Diagram SVG R2) = DiagramOpts+prettyOpt :: Parser PrettyOpt+prettyOpt = PrettyOpt <$> switch (long "pretty"+ O.<> short 'p'+ O.<> help "Pretty print the SVG output") - mainRender opts d = chooseRender opts d-#endif+instance Parseable PrettyOpt where+ parser = prettyOpt -chooseRender :: DiagramOpts -> Diagram SVG R2 -> IO ()-chooseRender opts d =+instance SVGFloat n => Mainable (QDiagram SVG V2 n Any) where+ type MainOpts (QDiagram SVG V2 n Any) = (DiagramOpts, DiagramLoopOpts, PrettyOpt)+ mainRender (opts, loopOpts, pretty) d = do+ chooseRender opts pretty d+ defaultLoopRender loopOpts++chooseRender :: SVGFloat n => DiagramOpts -> PrettyOpt -> QDiagram SVG V2 n Any -> IO ()+chooseRender opts pretty d = case splitOn "." (opts^.output) of [""] -> putStrLn "No output file given." ps | last ps `elem` ["svg"] -> do- let sizeSpec = case (opts^.width, opts^.height) 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 sizeSpec Nothing) d- BS.writeFile (opts^.output) (renderSvg build)+ let szSpec = fromIntegral <$> mkSizeSpec2D (opts^.width) (opts^.height)+ if isPretty pretty+ then renderSVG (opts^.output) szSpec d+ else renderPretty (opts^.output) szSpec d | otherwise -> putStrLn $ "Unknown file type: " ++ last ps -- | @multiMain@ is like 'defaultMain', except instead of a single@@ -220,61 +193,11 @@ -- $ ./MultiTest --selection bar -o Bar.eps -w 200 -- @ -multiMain :: [(String, Diagram SVG R2)] -> IO ()+multiMain :: SVGFloat n => [(String, QDiagram SVG V2 n Any)] -> IO () multiMain = mainWith -instance Mainable [(String,Diagram SVG R2)] where- type MainOpts [(String,Diagram SVG R2)] - = (MainOpts (Diagram SVG R2), DiagramMultiOpts)+instance SVGFloat n => Mainable [(String,QDiagram SVG V2 n Any)] where+ type MainOpts [(String,QDiagram SVG V2 n Any)]+ = (MainOpts (QDiagram SVG V2 n Any), DiagramMultiOpts) mainRender = defaultMultiMainRender---#ifdef CMDLINELOOP-waitForChange :: Maybe ModuleTime -> DiagramLoopOpts -> IO ()-waitForChange lastAttempt opts = do- prog <- getProgName- args <- getArgs- hSetBuffering stdout NoBuffering- go prog args lastAttempt- where go prog args lastAtt = do- threadDelay (1000000 * opts^.interval)- -- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")"- (newBin, newAttempt) <- recompile lastAtt prog (opts^.src)- if newBin- then executeFile prog False args Nothing- else go prog args $ 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 ModuleTime -> String -> Maybe String -> IO (Bool, Maybe ModuleTime)-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 <- Exc.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 <- getModuleTime- return (status == ExitSuccess, Just curTime)-- else return (False, Nothing)-- where getModTime f = Exc.catch (Just <$> getModificationTime f)- (\(SomeException _) -> return Nothing)-#endif
src/Graphics/Rendering/SVG.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -17,218 +18,242 @@ ----------------------------------------------------------------------------- module Graphics.Rendering.SVG- ( svgHeader+ ( SVGFloat+ , SvgM+ , AttributeValue+ , svgHeader , renderPath , renderClip , renderText , renderDImage+ , renderDImageEmb , renderStyles , renderMiterLimit , renderFillTextureDefs , renderFillTexture , renderLineTextureDefs , renderLineTexture+ , dataUri+ , getNumAttr ) where -- from base-import Data.List (intercalate, intersperse)---- from lens-import Control.Lens hiding (transform)+import Data.List (intercalate)+#if __GLASGOW_HASKELL__ < 710+import Data.Foldable (foldMap)+#endif+import Data.Monoid -- from diagrams-core import Diagrams.Core.Transform (matrixHomRep) -- from diagrams-lib-import Diagrams.Prelude hiding (Attribute, Render, (<>))+import Diagrams.Prelude hiding (Attribute, Render, with,+ (<>)) import Diagrams.TwoD.Path (getFillRule) import Diagrams.TwoD.Text --- from blaze-svg-import Text.Blaze.Svg11 (cr, hr, lr, m, mkPath, vr, z, (!))-import qualified Text.Blaze.Svg11 as S-import qualified Text.Blaze.Svg11.Attributes as A+-- from text+import Data.Text (pack)+import qualified Data.Text as T++-- from lucid-svg+import Lucid.Svg hiding (renderText)++-- from base64-bytestring, bytestring import qualified Data.ByteString.Base64.Lazy as BS64 import qualified Data.ByteString.Lazy.Char8 as BS8 +-- from JuicyPixels import Codec.Picture +-- | Constaint on number type that diagrams-svg can use to render an SVG. This+-- includes the common number types: Double, Float+type SVGFloat n = (Show n, TypeableFloat n)+-- Could we change Text.Blaze.SVG to use+-- showFFloat :: RealFloat a => Maybe Int -> a -> ShowS+-- or something similar for all numbers so we need TypeableFloat constraint.++-- | The Svg monad, synonym for @HtmlT m ()@ Lucid.Base.+type SvgM = Svg ()++type AttributeValue = T.Text++getNumAttr :: AttributeClass (a n) => (a n -> t) -> Style v n -> Maybe t+getNumAttr f = (f <$>) . getAttr+ -- | @svgHeader w h defs s@: @w@ width, @h@ height, -- @defs@ global definitions for defs sections, @s@ actual SVG content.-svgHeader :: Double -> Double -> Maybe S.Svg -> S.Svg -> S.Svg-svgHeader w h_ defines s = S.docTypeSvg- ! A.version "1.1"- ! A.width (S.toValue w)- ! A.height (S.toValue h_)- ! A.fontSize "1"- ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int]))- ! A.stroke "rgb(0,0,0)"- ! A.strokeOpacity "1"- $ do case defines of- Nothing -> return ()- Just defs -> S.defs $ defs- S.g $ s+svgHeader :: SVGFloat n => n -> n -> [Attribute] -> SvgM -> SvgM+svgHeader w h defines s = doctype_ <> with (svg11_ (g_ defines s))+ [ width_ (toText w)+ , height_ (toText h)+ , font_size_ "1"+ , viewBox_ (pack . unwords $ map show ([0, 0, round w, round h] :: [Int]))+ , stroke_ "rgb(0,0,0)"+ , stroke_opacity_ "1" ] -renderPath :: Path R2 -> S.Svg-renderPath trs = S.path ! A.d makePath+renderPath :: SVGFloat n => Path V2 n -> SvgM+renderPath trs = if makePath == T.empty then mempty else path_ [d_ makePath] where- makePath = mkPath $ mapM_ renderTrail (op Path trs)+ makePath = foldMap renderTrail (op Path trs) -renderTrail :: Located (Trail R2) -> S.Path-renderTrail (viewLoc -> (unp2 -> (x,y), t)) = m x y >> withTrail renderLine renderLoop t+renderTrail :: SVGFloat n => Located (Trail V2 n) -> AttributeValue+renderTrail (viewLoc -> (P (V2 x y), t)) = mA x y <> withTrail renderLine renderLoop t where- renderLine = mapM_ renderSeg . lineSegments- renderLoop lp = do+ renderLine = foldMap renderSeg . lineSegments+ renderLoop lp = case loopSegments lp of- -- let 'z' handle the last segment if it is linear- (segs, Linear _) -> mapM_ renderSeg segs+ -- let z handle the last segment if it is linear+ (segs, Linear _) -> foldMap renderSeg segs -- otherwise we have to emit it explicitly- _ -> mapM_ renderSeg (lineSegments . cutLoop $ lp)- z+ _ -> foldMap renderSeg (lineSegments . cutLoop $ lp)+ <> z -renderSeg :: Segment Closed R2 -> S.Path-renderSeg (Linear (OffsetClosed (unr2 -> (x,0)))) = hr x-renderSeg (Linear (OffsetClosed (unr2 -> (0,y)))) = vr y-renderSeg (Linear (OffsetClosed (unr2 -> (x,y)))) = lr x y-renderSeg (Cubic (unr2 -> (x0,y0))- (unr2 -> (x1,y1))- (OffsetClosed (unr2 -> (x2,y2))))- = cr x0 y0 x1 y1 x2 y2+renderSeg :: SVGFloat n => Segment Closed V2 n -> AttributeValue+renderSeg (Linear (OffsetClosed (V2 x 0))) = hR x+renderSeg (Linear (OffsetClosed (V2 0 y))) = vR y+renderSeg (Linear (OffsetClosed (V2 x y))) = lR x y+renderSeg (Cubic (V2 x0 y0)+ (V2 x1 y1)+ (OffsetClosed (V2 x2 y2))) = cR x0 y0 x1 y1 x2 y2 -renderClip :: Path R2 -> Int -> S.Svg -> S.Svg-renderClip p id_ svg = do- S.g ! A.clipPath (S.toValue $ "url(#" ++ clipPathId id_ ++ ")") $ do- S.clippath ! A.id_ (S.toValue $ clipPathId id_) $ renderPath p- svg- where clipPathId i = "myClip" ++ show i+renderClip :: SVGFloat n => Path V2 n -> T.Text -> Int -> SvgM -> SvgM+renderClip p prefix ident svg = do+ defs_ $ clipPath_ [id_ (clipPathId ident)] (renderPath p)+ g_ [clip_path_ $ ("url(#" <> clipPathId ident <> ")")] svg+ where+ clipPathId i = prefix <> "myClip" <> (toText i) -renderStop :: GradientStop -> S.Svg+renderStop :: SVGFloat n => GradientStop n -> SvgM renderStop (GradientStop c v)- = S.stop ! A.stopColor (S.toValue (colorToRgbString c))- ! A.offset (S.toValue (show v))- ! A.stopOpacity (S.toValue (colorToOpacity c))+ = stop_ [ stop_color_ (colorToRgbText c)+ , offset_ (toText v)+ , stop_opacity_ (toText $ colorToOpacity c) ] -spreadMethodStr :: SpreadMethod -> String-spreadMethodStr GradPad = "pad"-spreadMethodStr GradReflect = "reflect"-spreadMethodStr GradRepeat = "repeat"+spreadMethodText :: SpreadMethod -> AttributeValue+spreadMethodText GradPad = "pad"+spreadMethodText GradReflect = "reflect"+spreadMethodText GradRepeat = "repeat" -renderLinearGradient :: LGradient -> Int -> S.Svg-renderLinearGradient g i = S.lineargradient- ! A.id_ (S.toValue ("gradient" ++ (show i)))- ! A.x1 (S.toValue x1)- ! A.y1 (S.toValue y1)- ! A.x2 (S.toValue x2)- ! A.y2 (S.toValue y2)- ! A.gradienttransform (S.toValue matrix)- ! A.gradientunits "userSpaceOnUse"- ! A.spreadmethod (S.toValue (spreadMethodStr (g^.lGradSpreadMethod)))- $ do mconcat $ (map renderStop) (g^.lGradStops)+renderLinearGradient :: SVGFloat n => LGradient n -> Int -> SvgM+renderLinearGradient g i = linearGradient_+ [ id_ (pack $ "gradient" ++ show i)+ , x1_ (toText x1)+ , y1_ (toText y1)+ , x2_ (toText x2)+ , y2_ (toText y2)+ , gradientTransform_ mx+ , gradientUnits_ "userSpaceOnUse"+ , spreadMethod_ (spreadMethodText (g ^. lGradSpreadMethod)) ]+ $ foldMap renderStop (g^.lGradStops) where- matrix = S.matrix a1 a2 b1 b2 c1 c2- [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g^.lGradTrans)- (x1, y1) = unp2 (g^.lGradStart)- (x2, y2) = unp2 (g^.lGradEnd)+ mx = matrix a1 a2 b1 b2 c1 c2+ [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g ^. lGradTrans)+ P (V2 x1 y1) = g ^. lGradStart+ P (V2 x2 y2) = g ^. lGradEnd -renderRadialGradient :: RGradient -> Int -> S.Svg-renderRadialGradient g i = S.radialgradient- ! A.id_ (S.toValue ("gradient" ++ (show i)))- ! A.r (S.toValue (g^.rGradRadius1))- ! A.cx (S.toValue cx')- ! A.cy (S.toValue cy')- ! A.fx (S.toValue fx')- ! A.fy (S.toValue fy')- ! A.gradienttransform (S.toValue matrix)- ! A.gradientunits "userSpaceOnUse"- ! A.spreadmethod (S.toValue (spreadMethodStr (g^.rGradSpreadMethod)))- $ do mconcat $ map renderStop ss+renderRadialGradient :: SVGFloat n => RGradient n -> Int -> SvgM+renderRadialGradient g i = radialGradient_+ [ id_ (pack $ "gradient" ++ show i)+ , r_ (toText (g ^. rGradRadius1))+ , cx_ (toText cx)+ , cy_ (toText cy)+ , fx_ (toText fx)+ , fy_ (toText fy)+ , gradientTransform_ mx+ , gradientUnits_ "userSpaceOnUse"+ , spreadMethod_ (spreadMethodText (g ^. rGradSpreadMethod)) ]+ ( foldMap renderStop ss ) where- matrix = S.matrix a1 a2 b1 b2 c1 c2- [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g^.rGradTrans)- (cx', cy') = unp2 (g^.rGradCenter1)- (fx', fy') = unp2 (g^.rGradCenter0) -- SVG's focal point is our inner center.+ mx = matrix a1 a2 b1 b2 c1 c2+ [[a1, a2], [b1, b2], [c1, c2]] = matrixHomRep (g ^.rGradTrans)+ P (V2 cx cy) = g ^. rGradCenter1+ P (V2 fx fy) = g ^. rGradCenter0 -- SVGs focal point is our inner center. -- Adjust the stops so that the gradient begins at the perimeter of -- the inner circle (center0, radius0) and ends at the outer circle.- r0 = g^.rGradRadius0- r1 = g^.rGradRadius1- stopFracs = r0 / r1 : map (\s -> (r0 + (s^.stopFraction) * (r1-r0)) / r1)- (g^.rGradStops)- gradStops = case g^.rGradStops of+ r0 = g ^. rGradRadius0+ r1 = g ^. rGradRadius1+ stopFracs = r0 / r1 : map (\s -> (r0 + (s ^. stopFraction) * (r1 - r0)) / r1)+ (g ^. rGradStops)+ gradStops = case g ^. rGradStops of [] -> [] xs@(x:_) -> x : xs ss = zipWith (\gs sf -> gs & stopFraction .~ sf ) gradStops stopFracs -- Create a gradient element so that it can be used as an attribute value for fill.-renderFillTextureDefs :: Int -> Style v -> S.Svg+renderFillTextureDefs :: SVGFloat n => Int -> Style v n -> SvgM renderFillTextureDefs i s =- case (getFillTexture <$> getAttr s) of+ case getNumAttr getFillTexture s of Just (LG g) -> renderLinearGradient g i Just (RG g) -> renderRadialGradient g i _ -> mempty -- Render the gradient using the id set up in renderFillTextureDefs.-renderFillTexture :: Int -> Style v -> S.Attribute-renderFillTexture id_ s = case (getFillTexture <$> getAttr s) of- Just (SC (SomeColor c)) -> (renderAttr A.fill fillColorRgb) `mappend`- (renderAttr A.fillOpacity fillColorOpacity)+renderFillTexture :: SVGFloat n => Int -> Style v n -> [Attribute]+renderFillTexture ident s = case getNumAttr getFillTexture s of+ Just (SC (SomeColor c)) -> renderTextAttr fill_ fillColorRgb <>+ renderAttr fill_opacity_ fillColorOpacity where- fillColorRgb = Just $ colorToRgbString c+ fillColorRgb = Just $ colorToRgbText c fillColorOpacity = Just $ colorToOpacity c- Just (LG _) -> A.fill (S.toValue ("url(#gradient" ++ show id_ ++ ")"))- `mappend` A.fillOpacity "1"- Just (RG _) -> A.fill (S.toValue ("url(#gradient" ++ show id_ ++ ")"))- `mappend` A.fillOpacity "1"- Nothing -> mempty+ Just (LG _) -> [fill_ ("url(#gradient" <> toText ident <> ")"), fill_opacity_ "1"]+ Just (RG _) -> [fill_ ("url(#gradient" <> toText ident <> ")"), fill_opacity_ "1"]+ Nothing -> [] -renderLineTextureDefs :: Int -> Style v -> S.Svg+renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> SvgM renderLineTextureDefs i s =- case (getLineTexture <$> getAttr s) of+ case getNumAttr getLineTexture s of Just (LG g) -> renderLinearGradient g i Just (RG g) -> renderRadialGradient g i _ -> mempty -renderLineTexture :: Int -> Style v -> S.Attribute-renderLineTexture id_ s = case (getLineTexture <$> getAttr s) of- Just (SC (SomeColor c)) -> (renderAttr A.stroke lineColorRgb) `mappend`- (renderAttr A.strokeOpacity lineColorOpacity)+renderLineTexture :: SVGFloat n => Int -> Style v n -> [Attribute]+renderLineTexture ident s = case getNumAttr getLineTexture s of+ Just (SC (SomeColor c)) -> renderTextAttr stroke_ lineColorRgb <>+ renderAttr stroke_opacity_ lineColorOpacity where- lineColorRgb = Just $ colorToRgbString c+ lineColorRgb = Just $ colorToRgbText c lineColorOpacity = Just $ colorToOpacity c- Just (LG _) -> A.stroke (S.toValue ("url(#gradient" ++ show id_ ++ ")"))- `mappend` A.strokeOpacity "1"- Just (RG _) -> A.stroke (S.toValue ("url(#gradient" ++ show id_ ++ ")"))- `mappend` A.strokeOpacity "1"- Nothing -> mempty+ Just (LG _) -> [stroke_ ("url(#gradient" <> toText ident <> ")"), stroke_opacity_ "1"]+ Just (RG _) -> [stroke_ ("url(#gradient" <> toText ident <> ")"), stroke_opacity_ "1"]+ Nothing -> [] -renderDImage :: DImage Embedded -> S.Svg-renderDImage (DImage iD w h tr) =- S.image- ! A.transform transformMatrix- ! A.width (S.toValue w)- ! A.height (S.toValue h)- ! A.xlinkHref (S.preEscapedToValue (mkDataURI img))+dataUri :: String -> BS8.ByteString -> AttributeValue+dataUri mime dat = pack $ "data:"++mime++";base64," ++ BS8.unpack (BS64.encode dat)++renderDImageEmb :: SVGFloat n => DImage n Embedded -> SvgM+renderDImageEmb di@(DImage (ImageRaster dImg) _ _ _) =+ renderDImage di $ dataUri "image/png" img where- [[a,b],[c,d],[e,f]] = matrixHomRep (tr `mappend` reflectionY - `mappend` tX `mappend` tY)- transformMatrix = S.matrix a b c d e f- mkDataURI dat = "data:image/png;base64," ++ BS8.unpack (BS64.encode dat) img = case encodeDynamicPng dImg of Left str -> error str Right img' -> img'- ImageRaster dImg = iD++renderDImage :: SVGFloat n => DImage n any -> AttributeValue -> SvgM+renderDImage (DImage _ w h tr) uridata =+ image_+ [ transform_ transformMatrix+ , width_ (toText w)+ , height_ (toText h)+ , xlinkHref_ uridata ]+ where+ [[a,b],[c,d],[e,f]] = matrixHomRep (tr `mappend` reflectionY+ `mappend` tX `mappend` tY)+ transformMatrix = matrix a b c d e f tX = translationX $ fromIntegral (-w)/2 tY = translationY $ fromIntegral (-h)/2 -renderText :: Bool -> Text -> S.Svg-renderText isLocal (Text tt tn tAlign str) =- S.text_- ! A.transform transformMatrix- ! A.dominantBaseline vAlign- ! A.textAnchor hAlign- ! A.stroke "none" $- S.toMarkup str+renderText :: SVGFloat n => Text n -> SvgM+renderText (Text tt tAlign str) =+ text_+ [ transform_ transformMatrix+ , dominant_baseline_ vAlign+ , text_anchor_ hAlign+ , stroke_ "none" ]+ $ toHtml str where vAlign = case tAlign of BaselineText -> "alphabetic"@@ -242,12 +267,12 @@ w' | w' <= 0.25 -> "start" w' | w' >= 0.75 -> "end" _ -> "middle"- t = (if isLocal then tt else tn) `mappend` reflectionY+ t = tt `mappend` reflectionY [[a,b],[c,d],[e,f]] = matrixHomRep t- transformMatrix = S.matrix a b c d e f+ transformMatrix = matrix a b c d e f -renderStyles :: Int -> Int -> Style v -> S.Attribute-renderStyles fillId lineId s = mconcat . map ($ s) $+renderStyles :: SVGFloat n => Int -> Int -> Style v n -> [Attribute]+renderStyles fillId lineId s = concatMap ($ s) $ [ renderLineTexture lineId , renderFillTexture fillId , renderLineWidth@@ -260,102 +285,98 @@ , renderFontSlant , renderFontWeight , renderFontFamily- , renderMiterLimit- ]+ , renderMiterLimit ] -renderMiterLimit :: Style v -> S.Attribute-renderMiterLimit s = renderAttr A.strokeMiterlimit miterLimit+renderMiterLimit :: SVGFloat n => Style v n -> [Attribute]+renderMiterLimit s = renderAttr stroke_miterlimit_ miterLimit where miterLimit = getLineMiterLimit <$> getAttr s -renderOpacity :: Style v -> S.Attribute-renderOpacity s = renderAttr A.opacity opacity_- where opacity_ = getOpacity <$> getAttr s--renderFillRule :: Style v -> S.Attribute-renderFillRule s = renderAttr A.fillRule fillRule_- where fillRule_ = (fillRuleToStr . getFillRule) <$> getAttr s- fillRuleToStr :: FillRule -> String- fillRuleToStr Winding = "nonzero"- fillRuleToStr EvenOdd = "evenodd"+renderOpacity :: SVGFloat n => Style v n -> [Attribute]+renderOpacity s = renderAttr opacity_ o+ where o = getOpacity <$> getAttr s -renderLineWidth :: Style v -> S.Attribute-renderLineWidth s = renderAttr A.strokeWidth lineWidth'- where lineWidth' = (fromOutput . getLineWidth) <$> getAttr s+renderFillRule :: SVGFloat n => Style v n -> [Attribute]+renderFillRule s = renderTextAttr fill_rule_ fr+ where fr = (fillRuleToText . getFillRule) <$> getAttr s+ fillRuleToText :: FillRule -> AttributeValue+ fillRuleToText Winding = "nonzero"+ fillRuleToText EvenOdd = "evenodd" +renderLineWidth :: SVGFloat n => Style v n -> [Attribute]+renderLineWidth s = renderAttr stroke_width_ lWidth+ where lWidth = getNumAttr getLineWidth s -renderLineCap :: Style v -> S.Attribute-renderLineCap s = renderAttr A.strokeLinecap lineCap_- where lineCap_ = (lineCapToStr . getLineCap) <$> getAttr s- lineCapToStr :: LineCap -> String- lineCapToStr LineCapButt = "butt"- lineCapToStr LineCapRound = "round"- lineCapToStr LineCapSquare = "square"+renderLineCap :: SVGFloat n => Style v n -> [Attribute]+renderLineCap s = renderTextAttr stroke_linecap_ lCap+ where lCap = (lineCapToText . getLineCap) <$> getAttr s+ lineCapToText :: LineCap -> AttributeValue+ lineCapToText LineCapButt = "butt"+ lineCapToText LineCapRound = "round"+ lineCapToText LineCapSquare = "square" -renderLineJoin :: Style v -> S.Attribute-renderLineJoin s = renderAttr A.strokeLinejoin lineJoin_- where lineJoin_ = (lineJoinToStr . getLineJoin) <$> getAttr s- lineJoinToStr :: LineJoin -> String- lineJoinToStr LineJoinMiter = "miter"- lineJoinToStr LineJoinRound = "round"- lineJoinToStr LineJoinBevel = "bevel"+renderLineJoin :: SVGFloat n => Style v n -> [Attribute]+renderLineJoin s = renderTextAttr stroke_linejoin_ lj+ where lj = (lineJoinToText . getLineJoin) <$> getAttr s+ lineJoinToText :: LineJoin -> AttributeValue+ lineJoinToText LineJoinMiter = "miter"+ lineJoinToText LineJoinRound = "round"+ lineJoinToText LineJoinBevel = "bevel" -renderDashing :: Style v -> S.Attribute-renderDashing s = (renderAttr A.strokeDasharray arr) `mappend`- (renderAttr A.strokeDashoffset dOffset)+renderDashing :: SVGFloat n => Style v n -> [Attribute]+renderDashing s = renderTextAttr stroke_dasharray_ arr <>+ renderAttr stroke_dashoffset_ dOffset where- getDasharray (Dashing a _) = map fromOutput a- getDashoffset (Dashing _ o) = fromOutput o+ getDasharray (Dashing a _) = a+ getDashoffset (Dashing _ o) = o dashArrayToStr = intercalate "," . map show- dashing_ = getDashing <$> getAttr s- arr = (dashArrayToStr . getDasharray) <$> dashing_- dOffset = getDashoffset <$> dashing_+ dashing' = getNumAttr getDashing s+ arr = (pack . dashArrayToStr . getDasharray) <$> dashing'+ dOffset = getDashoffset <$> dashing' -renderFontSize :: Style v -> S.Attribute-renderFontSize s = renderAttr A.fontSize fontSize_+renderFontSize :: SVGFloat n => Style v n -> [Attribute]+renderFontSize s = renderTextAttr font_size_ fs where- fontSize_ = ((++ "em") . str . getFontSize) <$> getAttr s- str o = show $ fromOutput o+ fs = pack <$> getNumAttr ((++ "px") . show . getFontSize) s -renderFontSlant :: Style v -> S.Attribute-renderFontSlant s = renderAttr A.fontStyle fontSlant_+renderFontSlant :: SVGFloat n => Style v n -> [Attribute]+renderFontSlant s = renderTextAttr font_style_ fs where- fontSlant_ = (fontSlantAttr . getFontSlant) <$> getAttr s- fontSlantAttr :: FontSlant -> String+ fs = (fontSlantAttr . getFontSlant) <$> getAttr s+ fontSlantAttr :: FontSlant -> AttributeValue fontSlantAttr FontSlantItalic = "italic" fontSlantAttr FontSlantOblique = "oblique" fontSlantAttr FontSlantNormal = "normal" -renderFontWeight :: Style v -> S.Attribute-renderFontWeight s = renderAttr A.fontWeight fontWeight_+renderFontWeight :: SVGFloat n => Style v n -> [Attribute]+renderFontWeight s = renderTextAttr font_weight_ fw where- fontWeight_ = (fontWeightAttr . getFontWeight) <$> getAttr s- fontWeightAttr :: FontWeight -> String+ fw = (fontWeightAttr . getFontWeight) <$> getAttr s+ fontWeightAttr :: FontWeight -> AttributeValue fontWeightAttr FontWeightNormal = "normal" fontWeightAttr FontWeightBold = "bold" -renderFontFamily :: Style v -> S.Attribute-renderFontFamily s = renderAttr A.fontFamily fontFamily_+renderFontFamily :: SVGFloat n => Style v n -> [Attribute]+renderFontFamily s = renderTextAttr font_family_ ff where- fontFamily_ = getFont <$> getAttr s+ ff = (pack . getFont) <$> getAttr s -- | Render a style attribute if available, empty otherwise.-renderAttr :: S.ToValue s => (S.AttributeValue -> S.Attribute)- -> Maybe s- -> S.Attribute-renderAttr attr valM = case valM of- Just val -> attr (S.toValue val)- Nothing -> mempty+renderAttr :: Show s => (AttributeValue -> Attribute) -> Maybe s -> [Attribute]+renderAttr attr valM = maybe [] (\v -> [attr (toText v)]) valM -colorToRgbString :: forall c . Color c => c -> String-colorToRgbString c = concat+renderTextAttr :: (AttributeValue -> Attribute) -> Maybe AttributeValue -> [Attribute]+renderTextAttr attr valM = maybe [] (\v -> [attr v]) valM++colorToRgbText :: forall c . Color c => c -> AttributeValue+colorToRgbText c = T.concat [ "rgb(" , int r, "," , int g, "," , int b- , ")"- ]- where int d = show (round (d * 255) :: Int)- (r,g,b,_) = colorToSRGBA c+ , ")" ]+ where+ int d = toText (round (d * 255) :: Int)+ (r,g,b,_) = colorToSRGBA c colorToOpacity :: forall c . Color c => c -> Double colorToOpacity c = a