diagrams-svg 1.1.0.5 → 1.5
raw patch · 8 files changed
Files
- CHANGELOG.md +521/−0
- CHANGES.markdown +0/−176
- LICENSE +11/−1
- README.md +5/−1
- diagrams-svg.cabal +23/−31
- src/Diagrams/Backend/SVG.hs +318/−218
- src/Diagrams/Backend/SVG/CmdLine.hs +42/−122
- src/Graphics/Rendering/SVG.hs +263/−216
+ CHANGELOG.md view
@@ -0,0 +1,521 @@+## [v1.5](https://github.com/diagrams/diagrams-svg/tree/v1.5) (2025-03-25)++- Allow `base-4.21` and test on GHC 9.12+- Allow `diagrams-lib-1.5` and remove `DiagramLoopOpts` which is no+ longer supported++## [v1.4.4](https://github.com/diagrams/diagrams-svg/tree/v1.4.4) (2025-03-05)++- New `svgAttr` function, for adding arbitrary attribute/value pairs+ to nodes. Thanks to @Chobbes for the [PR](https://github.com/diagrams/diagrams-svg/pull/124).++## [v1.4.3.2](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.2) (2024-08-27)++- Allow `hashable-1.5`+- Fix `examples/opts.hs` (thanks to @PiotrJustyna)++## [v1.4.3.1-r7](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r7) (2024-07-02)++- Allow `filepath-1.5`, `containers-0.7`, and `lens-5.3`+- Test on GHC 9.10++## [v1.4.3.1-r6](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r6) (2024-01-20)++- Allow `base-4.19` and `text-2.1`+- Test on GHC 9.8++## [v1.4.3.1-r5](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r5) (2023-05-30)++- Allow `base-4.18`, `mtl-2.3`, `optparse-applicative-0.18`, and test on GHC 9.6++## [v1.4.3.1-r4](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r4) (2022-09-05)++- Allow `base-4.17`, `lens-5.2`, and test on GHC 9.4++## [v1.4.3.1-r3](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r3) (2022-02-02)++- Allow `optparse-applicative-0.17`.++## [v1.4.3.1-r2](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r2) (2022-01-10)++- Allow `text-2.0`.++## [v1.4.3.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1) (2021-12-28)++- Dependency upper bounds updates to allow:+ - `base-4.16` (GHC 9.2)+ - `lens-5.1`+ - `hashable-1.4`+ - `semigroups-0.20`+- Add `Eq` instance for `Options SVG` and (orphan) `Eq` instance for `Element`++## [v1.4.3-r3](https://github.com/diagrams/diagrams-svg/tree/v1.4.3-r3) (2021-06-08)++Dependency upper bounds updates, to allow:++- `base-4.15` (GHC 9.0)+- `base64-bytestring-1.2`+- `diagrams-core-1.5`+- `monoid-extras-0.6`+- `lens-5.0`+- `optparse-applicative-0.16`++## [v1.4.3](https://github.com/diagrams/diagrams-svg/tree/v1.4.3) (2019-12-10)++- Allow `base-4.13` (GHC 8.8), `lens-4.18`, `semigroups-0.19`,+ `hashable-1.3`, `optparse-applicative-0.15`+- Stop rounding the coordinates of the viewbox+ ([#109](https://github.com/diagrams/diagrams-svg/issues/109))+- New `svgClass`, `svgId`, and `svgTitle` functions for setting SVG+ attributes via annotations++## [v1.4.2](https://github.com/diagrams/diagrams-svg/tree/v1.4.2) (2018-05-09)++- Allow `base-4.11` (GHC 8.4) and `lens-4.16`+- Add `Semigroup (Render SVG V2 n)` instance++## [v1.4.1.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.1.1) (2017-08-23)++- Allow `base-4.10` and `optparse-applicative-0.14`+- Fix gradients applied to text ([#98](https://github.com/diagrams/diagrams-svg/issues/98))++## [v1.4.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.1) (2016-10-26)++- Handle wider range of font weight specifications+- allow `lens-4.15`++## [v1.4.0.4](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.4) (2016-08-22)++- Require `optparse-applicative-0.13`, and fix compilation error++## [v1.4.0.3](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.3) (2016-08-16)++- Allow `optparse-applicative-0.13`++## [v1.4.0.2](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.2) (2016-06-06)++- allow `base-4.9`+- test with GHC 8.0+- minor documentation updates++## [v1.4.0.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.1) (2016-05-01)++- allow `lens-4.14`++## [v1.4](https://github.com/diagrams/diagrams-svg/tree/v1.4) (2016-02-14)++-- Changes for `svg-builder`+-- Deprecate `svgId` and `svgClass`++## [v1.3.1.8](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.8) (2015-11-14)++- allow `lucid-svg-0.6`++## [v1.3.1.7](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.7) (2015-11-10)++- allow `semigroups-0.18`++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.6...v1.3.1.7)++## [v1.3.1.6](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.6) (2015-09-29)++- allow `optparse-applicative-0.12`++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.5...v1.3.1.6)+++## [v1.3.1.5](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.5) (2015-09-19)++- allow `lens-4.13` and `semigroups-0.17`++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.4...v1.3.1.5)++## [v1.3.1.4](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.4) (2015-07-19)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.3...v1.3.1.4)++## [v1.3.1.3](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.2) (2015-07-09)++- Changes to allow `lucid-svg-0.5`++## [v1.3.1.2](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.2) (2015-05-26)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.1...v1.3.1.2)++## [v1.3.1.1](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.1) (2015-05-06)++**Bug Fix**: handle empty dashing array properly ([\#80](https://github.com/diagrams/diagrams-svg/pull/80))++## [v1.3.1](https://github.com/diagrams/diagrams-svg/tree/v1.3.1) (2015-04-30)++**API Changes**++ - Type of `SVGOptions` changed. `_svgDefinitions :: Maybe SvgM`++**Internal Changes**++ - Use `ReaderT` for styles++## [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,12 +1,22 @@-Copyright 2011-2014 diagrams-svg team:+Copyright 2011-2016 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>+ Michael Chavinda <mchavinda@colgate.edu>+ Tad Doxsee <doxsee@pacbell.net> Daniil Frumin <difrumin@gmail.com>+ Ben Gamari <bgamari.foss@gmail.com>+ Gabor Greif <ggreif@gmail.com> Deepak Jois <deepak.jois@gmail.com>+ Sidharth Kapur <sidharthkapur1@gmail.com>+ Taru Karttunen <taruti@taruti.net> Felipe Lessa <felipe.lessa@gmail.com>+ Andrew Martin <andrew.thaddeus@gmail.com> Chris Mears <chris@cmears.id.au> Jeffrey Rosenbluth <Jeffrey.Rosenbluth@gmail.com>+ Ryan Scott <ryan.gl.scott@ku.edu> Michael Sloan <mgsloan@gmail.com> Michael Thompson <what_is_it_to_do_anything@yahoo.com> Ryan Yates <fryguybob@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) [)](https://github.com/diagrams/diagrams-svg/actions/workflows/haskell-ci.yml)+------------ + _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].@@ -26,6 +28,7 @@ import Diagrams.Prelude import Diagrams.Backend.SVG.CmdLine +b1 :: Diagram B b1 = square 20 # lw 0.002 main = mainWith (pad 1.1 b1)@@ -55,6 +58,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.5 Synopsis: SVG backend for diagrams drawing EDSL.-Homepage: http://projects.haskell.org/diagrams/+Homepage: https://diagrams.github.io/ 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 ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 || ==9.10.1 || ==9.12.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 @svg-builder@ to be a native Haskell backend, making it suitable for use on any platform. .@@ -40,32 +40,24 @@ Diagrams.Backend.SVG.CmdLine Other-modules: Graphics.Rendering.SVG Hs-source-dirs: src- Build-depends: base >= 4.3 && < 4.8- , 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- , 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- , time- , containers >= 0.3 && < 0.6- , lens >= 4.0 && < 4.10- , hashable >= 1.1 && < 1.3- if impl(ghc < 7.6)- build-depends: ghc-prim- if !os(windows)- cpp-options: -DCMDLINELOOP- Build-depends: unix >= 2.4 && < 2.8+ Build-depends: base >= 4.7 && < 4.22+ , filepath >= 1.4 && < 1.6+ , mtl >= 1 && < 2.4+ , bytestring >= 0.9 && < 1.0+ , base64-bytestring >= 1 && < 1.3+ , colour >= 2.3 && < 2.4+ , diagrams-core >= 1.4 && < 1.6+ , diagrams-lib >= 1.4.5 && < 1.6+ , monoid-extras >= 0.3 && < 0.7+ , svg-builder >= 0.1 && < 0.2+ , text >= 0.11 && < 2.2+ , JuicyPixels >= 3.1.5 && < 3.4+ , split >= 0.1.2 && < 0.3+ , containers >= 0.3 && < 0.8+ , lens >= 4.0 && < 5.4+ , hashable >= 1.1 && < 1.6+ , optparse-applicative >= 0.13 && < 0.19+ , semigroups >= 0.13 && < 0.21 Ghc-options: -Wall
src/Diagrams/Backend/SVG.hs view
@@ -1,19 +1,28 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ---------------------------------------------------------------------------- -- | -- 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 +35,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 +49,397 @@ -- '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 :: Maybe Element+-- > -- ^ Custom definitions that will be added to the @defs@+-- > -- section of the output.+-- > , _idPrefix :: T.Text+-- > , _svgAttributes :: [Attribute]+-- > -- ^ Attributes to apply to the entire svg element.+-- > , _generateDoctype :: Bool+-- > } -- -- @--- 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 = 'Element' -- @ -- -- 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.Element' -- @ ----- 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)+-- Nothing "" [] True) 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.Svg.Core.Element' value, which+-- you can, /e.g./ render to a 'ByteString' using 'Graphics.Svg.Core.renderBS'+-- from the 'svg-builder' package. -- ----------------------------------------------------------------------------- module Diagrams.Backend.SVG ( SVG(..) -- rendering token , B- , Options(..), size, svgDefinitions -- for rendering options specific to SVG+ -- for rendering options specific to SVG+ , Options(..), sizeSpec, svgDefinitions, idPrefix, svgAttributes, generateDoctype+ , svgClass, svgId, svgTitle, svgAttr+ , SVGFloat , renderSVG+ , renderSVG'+ , renderPretty+ , renderPretty'+ , loadImageSVG ) where --- for testing-import Data.Foldable (foldMap)+-- from JuicyPixels+import Codec.Picture (decodeImage, encodeDynamicPng)+import Codec.Picture.Types (DynamicImage (ImageYCbCr8),+ dynamicMap, imageHeight, imageWidth)++#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.Reader import Control.Monad.State+import Data.Char+import Data.Function (on) import Data.Typeable-import GHC.Generics (Generic) -- from hashable-import Data.Hashable (Hashable (..))+import Data.Hashable (Hashable (), hashWithSalt) -- 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 (..), keyVal) -- 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, local, size, view,+ with)+import Diagrams.TwoD.Adjust (adjustDia2D)+import Diagrams.TwoD.Attributes (FillTexture, 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 svg-builder+import Graphics.Svg hiding ((<>)) -- from this package-import qualified Graphics.Rendering.SVG as R+import Graphics.Rendering.SVG (SVGFloat)+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 Environment n = Environment+ { _style :: Style V2 n+ , __pre :: T.Text+ }++makeLenses ''Environment++data SvgRenderState = SvgRenderState+ { _clipPathId :: Int+ , _fillGradId :: Int+ , _lineGradId :: Int+ }+ makeLenses ''SvgRenderState +initialEnvironment :: SVGFloat n => T.Text -> Environment n+initialEnvironment = Environment (mempty # recommendFillColor transparent)+ -- Fill gradients ids are even, line gradient ids are odd. initialSvgRenderState :: SvgRenderState-initialSvgRenderState = SvgRenderState 0 0 1 True+initialSvgRenderState = SvgRenderState 0 0 1 --- | 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+-- | Monad to keep track of environment and state when rendering an SVG.+type SvgRenderM n = ReaderT (Environment n) (State SvgRenderState) Element -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)+runRenderM :: SVGFloat n => T.Text -> SvgRenderM n -> Element+runRenderM o s = flip evalState initialSvgRenderState+ $ runReaderT s (initialEnvironment o) +instance Semigroup (Render SVG V2 n) where+ R r1 <> R r2_ = R $ do+ svg1 <- r1+ svg2 <- r2_+ return (svg1 `mappend` svg2)++instance Monoid (Render SVG V2 n) where+ mempty = R $ return mempty+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif+ -- 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+ -> Element -- ^ 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 :: [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+ newtype Render SVG V2 n = R (SvgRenderM n)+ type Result SVG V2 n = Element+ data Options SVG V2 n = SVGOptions+ { _size :: SizeSpec V2 n -- ^ The requested size.+ , _svgDefinitions :: Maybe Element -- ^ Custom definitions that will be added to the @defs@ -- section of the output.- }+ , _idPrefix :: T.Text+ , _svgAttributes :: [Attribute]+ -- ^ Attriubtes to apply to the entire svg element.+ , _generateDoctype :: Bool+ }+ deriving Eq - renderRTree _ opts rt = evalState svgOutput initialSvgRenderState+ renderRTree :: SVG -> Options SVG V2 n -> RTree SVG V2 n Annotation -> Result SVG V2 n+ renderRTree _ opts rt = runRenderM (opts ^.idPrefix) svgOutput 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-- adjustDia c opts d = adjustDia2D size c opts (d # reflectY)+ return $ R.svgHeader w h (opts^.svgDefinitions)+ (opts^.svgAttributes)+ (opts^.generateDoctype) svg -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+ adjustDia c opts d = ( sz, t <> reflectionY, d' ) where+ (sz, t, d') = adjustDia2D sizeSpec c opts (d # reflectY) - -- 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+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 $ local (over style (<> sty)) r+ RAnnot (OpacityGroup o) -> R $ g_ [Opacity_ <<- toText o] <$> r+ RAnnot (Href uri) -> R $ a_ [XlinkHref_ <<- T.pack uri] <$> r+ RAnnot (KeyVal ("title",v)) -> R $ do+ e <- r+ pure $ g_ [] $ e <> title_ [] (toElement v)+ RAnnot (KeyVal (attr,v)) -> R $ with <$> r <*> pure [makeAttribute (T.pack attr) (T.pack v)]+ _ -> R r+ where+ R r = foldMap rtree rs - 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+-- | Set the id for a particular SVG diagram+svgId :: SVGFloat n => String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any+svgId = svgAttr "id" -getSize :: Options SVG R2 -> SizeSpec2D-getSize (SVGOptions {_size = s}) = s+-- | Set the class for a particular SVG diagram+svgClass :: SVGFloat n => String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any+svgClass = svgAttr "class" -setSize :: Options SVG R2 -> SizeSpec2D -> Options SVG R2-setSize o s = o {_size = s}+-- | Set the title text for a particular SVG diagram+svgTitle :: SVGFloat n => String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any+svgTitle = svgAttr "title" -size :: Lens' (Options SVG R2) SizeSpec2D-size = lens getSize setSize+-- | Set an arbitrary attribute for a particular SVG diagram+svgAttr :: SVGFloat n => String -> String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any+svgAttr attr = curry keyVal attr -getSVGDefs :: Options SVG R2 -> Maybe S.Svg-getSVGDefs (SVGOptions {_svgDefinitions = d}) = d+-- | Lens onto the size of the svg options.+sizeSpec :: Lens' (Options SVG V2 n) (SizeSpec V2 n)+sizeSpec f opts = f (_size opts) <&> \s -> opts { _size = s } -setSVGDefs :: Options SVG R2 -> Maybe S.Svg -> Options SVG R2-setSVGDefs o d = o {_svgDefinitions = d}+-- | Lens onto the svg definitions of the svg options.+svgDefinitions :: Lens' (Options SVG V2 n) (Maybe Element)+svgDefinitions f opts =+ f (_svgDefinitions opts) <&> \ds -> opts { _svgDefinitions = ds } -svgDefinitions :: Lens' (Options SVG R2) (Maybe S.Svg)-svgDefinitions = lens getSVGDefs setSVGDefs+-- | 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 :: Lens' (Options SVG V2 n) T.Text+idPrefix f opts = f (_idPrefix opts) <&> \i -> opts { _idPrefix = i } -instance Hashable (Options SVG R2) where- hashWithSalt s (SVGOptions sz defs) =- s `hashWithSalt` sz `hashWithSalt` defs+-- | Lens onto the svgAttributes field of the svg options. This field+-- is provided to supply SVG attributes to the entire diagram.+svgAttributes :: Lens' (Options SVG V2 n) [Attribute]+svgAttributes f opts =+ f (_svgAttributes opts) <&> \ds -> opts { _svgAttributes = ds } -instance Hashable StaticString where- hashWithSalt s (StaticString dl bs txt)- = s `hashWithSalt` dl [] `hashWithSalt` bs `hashWithSalt` txt+-- | Lens onto the generateDoctype field of the svg options. Set+-- to False if you don't want a doctype tag included in the output.+generateDoctype :: Lens' (Options SVG V2 n) Bool+generateDoctype f opts =+ f (_generateDoctype opts) <&> \ds -> opts { _generateDoctype = ds } -deriving instance Generic ChoiceString+-- paths --------------------------------------------------------------- -instance Hashable ChoiceString+attributedRender :: SVGFloat n => Element -> SvgRenderM n+attributedRender svg = do+ SvgRenderState _idClip idFill idLine <- get+ Environment sty preT <- ask+ clippedSvg <- renderSvgWithClipping preT svg sty+ lineGradDefs <- lineTextureDefs sty+ fillGradDefs <- fillTextureDefs sty+ return $ do+ let gDefs = mappend fillGradDefs lineGradDefs+ gDefs `mappend` g_ (R.renderStyles idFill idLine sty) clippedSvg -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)+instance SVGFloat n => Renderable (Path V2 n) SVG where+ render _ = R . attributedRender . R.renderPath -instance Renderable (Path R2) SVG where- render _ = R . return . R.renderPath+instance SVGFloat n => Renderable (Text n) SVG where+ render _ t@(Text tTxt _ _) = R $ do+ let svg = R.renderText t+ SvgRenderState _idClip idFill idLine <- get+ Environment sty preT <- ask+ clippedSvg <- renderSvgWithClipping preT svg sty -instance Renderable Text SVG where- render _ t = R $ do- isLocal <- use isLocalText- return $ R.renderText isLocal t+ -- SVG applies the text transform to the gradient before rendering.+ -- This means we need to apply the inverse of the text transform+ -- first, being careful about how we use reflectionY to handle SVG's+ -- coordinates.+ let adjustTrans :: Maybe (FillTexture n) -> Maybe (FillTexture n)+ adjustTrans = _Just . _FillTexture . committed . _LG . lGradTrans %~+ \tGrad -> inv (tTxt <> reflectionY) <> tGrad <> reflectionY -instance Renderable (DImage Embedded) SVG where- render _ = R . return . R.renderDImage+ fillGradDefs <- fillTextureDefs (sty & atAttr %~ adjustTrans)+ return $+ fillGradDefs `mappend` g_ (R.renderStyles idFill idLine sty) clippedSvg --- TODO: instance Renderable Image SVG where+instance SVGFloat n => Renderable (DImage n Embedded) SVG where+ render _ = R . return . R.renderDImageEmb -- | 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)+renderSVG :: SVGFloat n => FilePath -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO ()+renderSVG outFile spec = renderSVG' outFile (SVGOptions spec Nothing (mkPrefix outFile) [] True)++-- | 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 Nothing (mkPrefix outFile)[] True)++-- 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++-- | 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++-- | 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++data Img = Img !Char !BS.ByteString deriving Typeable++-- | 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 -> pic 'P' dat+ | jpgHeader `SBS.isPrefixOf` raw -> pic 'J' dat+ | otherwise -> 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++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"+ _ -> error "Unknown mime type while rendering image"+ return $ R.renderDImage di $ R.dataUri mime d++instance Hashable n => Hashable (Options SVG V2 n) where+ hashWithSalt s (SVGOptions sz defs ia sa gd) =+ s `hashWithSalt`+ sz `hashWithSalt`+ ds `hashWithSalt`+ ia `hashWithSalt`+ sa `hashWithSalt`+ gd+ where ds = fmap renderBS defs++-- This is an orphan instance. Since Element is defined as a newtype+-- of (HashMap Text Text -> Builder), it doesn't really make sense to+-- define an Eq instance for it in general. However, as of+-- hashable-1.4 an Eq superclass was added to Hashable, so in order to+-- have a Hashable instance for Options SVG, we need to have a+-- matching Eq instance.+instance Eq Element where+ (==) = (==) `on` renderBS
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@@ -46,12 +50,12 @@ -- "Diagrams.Backend.SVG" for more information. -- -- For a tutorial on command-line diagram creation see--- <http://projects.haskell.org/diagrams/doc/cmdline.html>.--- +-- <https://diagrams.github.io/doc/cmdline.html>.+-- ----------------------------------------------------------------------------- module Diagrams.Backend.SVG.CmdLine- ( + ( -- * General form of @main@ -- $mainwith @@ -68,45 +72,14 @@ , 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 -# 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 +90,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 +98,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 +120,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 +131,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 +143,32 @@ -- $ ./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"+ <> short 'p'+ <> 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, PrettyOpt)+ mainRender (opts, pretty) d = chooseRender opts pretty d++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 renderPretty (opts^.output) szSpec d+ else renderSVG (opts^.output) szSpec d | otherwise -> putStrLn $ "Unknown file type: " ++ last ps -- | @multiMain@ is like 'defaultMain', except instead of a single@@ -220,61 +190,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,11 @@-{-# 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 #-}+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- |@@ -17,218 +19,253 @@ ----------------------------------------------------------------------------- module Graphics.Rendering.SVG- ( svgHeader+ ( SVGFloat+ , Element+ , AttributeValue+ , svgHeader , renderPath , renderClip , renderText , renderDImage+ , renderDImageEmb , renderStyles , renderMiterLimit , renderFillTextureDefs , renderFillTexture , renderLineTextureDefs , renderLineTexture+ , dataUri+ , getNumAttr ) where -- from base-import Data.List (intercalate, intersperse)+import Data.List (intercalate)+#if __GLASGOW_HASKELL__ < 710+import Data.Foldable (foldMap)+#endif --- from lens-import Control.Lens hiding (transform)+import Data.Maybe (fromMaybe)+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif -- 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 svg-builder+import Graphics.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.++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 -> Maybe Element -> [Attribute] -> Bool+ -> Element -> Element+svgHeader w h defines attributes genDoctype s =+ dt <> with (svg11_ (defs_ [] ds <> s))+ ([ Width_ <<- toText w+ , Height_ <<- toText h+ , Font_size_ <<- "1"+ , ViewBox_ <<- (pack . unwords $ map show [0, 0, w, h])+ , Stroke_ <<- "rgb(0,0,0)"+ , Stroke_opacity_ <<- "1" ]+ ++ attributes )+ where+ ds = fromMaybe mempty defines+ dt = if genDoctype then doctype else mempty -renderPath :: Path R2 -> S.Svg-renderPath trs = S.path ! A.d makePath+renderPath :: SVGFloat n => Path V2 n -> Element+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 -> Element -> Element+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" <> (pack . show $ i) -renderStop :: GradientStop -> S.Svg+renderStop :: SVGFloat n => GradientStop n -> Element 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 -> Element+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 -> Element+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 -> Element renderFillTextureDefs i s =- case (getFillTexture <$> getAttr s) of- Just (LG g) -> renderLinearGradient g i- Just (RG g) -> renderRadialGradient g i+ case getNumAttr getFillTexture s of+ Just (LG g) -> defs_ [] $ renderLinearGradient g i+ Just (RG g) -> defs_ [] $ 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" <> (pack . show $ ident)+ <> ")"), Fill_opacity_ <<- "1"]+ Just (RG _) -> [Fill_ <<- ("url(#gradient" <> (pack . show $ ident)+ <> ")"), Fill_opacity_ <<- "1"]+ Nothing -> [] -renderLineTextureDefs :: Int -> Style v -> S.Svg+renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> Element renderLineTextureDefs i s =- case (getLineTexture <$> getAttr s) of- Just (LG g) -> renderLinearGradient g i- Just (RG g) -> renderRadialGradient g i+ case getNumAttr getLineTexture s of+ Just (LG g) -> defs_ [] $ renderLinearGradient g i+ Just (RG g) -> defs_ [] $ 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" <> (pack . show $ ident)+ <> ")"), Stroke_opacity_ <<- "1"]+ Just (RG _) -> [Stroke_ <<- ("url(#gradient" <> (pack . show $ 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 -> Element+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 -> Element+renderDImage (DImage _ w h tr) uridata =+ image_+ [ Transform_ <<- transformMatrix+ , Width_ <<- (pack . show $ w)+ , Height_ <<- (pack . show $ 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 -> Element+renderText (Text tt tAlign str) =+ text_+ [ Transform_ <<- transformMatrix+ , Dominant_baseline_ <<- vAlign+ , Text_anchor_ <<- hAlign+ , Stroke_ <<- "none" ]+ $ toElement str where vAlign = case tAlign of BaselineText -> "alphabetic"@@ -242,12 +279,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 +297,112 @@ , renderFontSlant , renderFontWeight , renderFontFamily- , renderMiterLimit- ]+ , renderMiterLimit ] -renderMiterLimit :: Style v -> S.Attribute-renderMiterLimit s = renderAttr A.strokeMiterlimit miterLimit+renderMiterLimit :: 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 :: 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 :: 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 :: 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 :: 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- dashArrayToStr = intercalate "," . map show- dashing_ = getDashing <$> getAttr s- arr = (dashArrayToStr . getDasharray) <$> dashing_- dOffset = getDashoffset <$> dashing_+ getDasharray (Dashing a _) = a+ getDashoffset (Dashing _ o) = o+ dashArrayToStr = intercalate "," . map show+ -- Ignore dashing if dashing array is empty+ checkEmpty (Just (Dashing [] _)) = Nothing+ checkEmpty other = other+ dashing' = checkEmpty $ 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 :: 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 :: 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"+ fontWeightAttr FontWeightLighter = "lighter"+ fontWeightAttr FontWeightBolder = "bolder"+ fontWeightAttr FontWeightThin = "100"+ fontWeightAttr FontWeightUltraLight = "200"+ fontWeightAttr FontWeightLight = "300"+ fontWeightAttr FontWeightMedium = "400"+ fontWeightAttr FontWeightSemiBold = "600"+ fontWeightAttr FontWeightUltraBold = "800"+ fontWeightAttr FontWeightHeavy = "900" -renderFontFamily :: Style v -> S.Attribute-renderFontFamily s = renderAttr A.fontFamily fontFamily_++renderFontFamily :: 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 => AttrTag -> Maybe s -> [Attribute]+renderAttr attr valM = maybe [] (\v -> [(bindAttr attr) (pack . show $ v)]) valM -colorToRgbString :: forall c . Color c => c -> String-colorToRgbString c = concat+-- renderTextAttr :: (AttributeValue -> Attribute) -> Maybe AttributeValue -> [Attribute]+renderTextAttr :: AttrTag -> Maybe AttributeValue -> [Attribute]+renderTextAttr attr valM = maybe [] (\v -> [(bindAttr 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 = pack . show $ (round (d * 255) :: Int)+ (r,g,b,_) = colorToSRGBA c colorToOpacity :: forall c . Color c => c -> Double colorToOpacity c = a