diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 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)* diff --git a/CHANGES.markdown b/CHANGES.markdown deleted file mode 100644 --- a/CHANGES.markdown +++ /dev/null @@ -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). diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,12 +1,22 @@ -Copyright 2011-2014 diagrams-svg team: +Copyright 2011-2016 diagrams-svg team: + Doug Beardsley Daniel Bergey Jan Bracker + Christopher Chalmers + Michael Chavinda + Tad Doxsee Daniil Frumin + Ben Gamari + Gabor Greif Deepak Jois + Sidharth Kapur + Taru Karttunen Felipe Lessa + Andrew Martin Chris Mears Jeffrey Rosenbluth + Ryan Scott Michael Sloan Michael Thompson Ryan Yates diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ -[![Build Status](https://secure.travis-ci.org/diagrams/diagrams-svg.png)](http://travis-ci.org/diagrams/diagrams-svg) +diagrams-svg [![Hackage](https://img.shields.io/hackage/v/diagrams-svg.svg?style=flat)](https://hackage.haskell.org/package/diagrams-svg) [![Build Status](https://github.com/diagrams/diagrams-svg/actions/workflows/haskell-ci.yml/badge.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 diff --git a/diagrams-svg.cabal b/diagrams-svg.cabal --- a/diagrams-svg.cabal +++ b/diagrams-svg.cabal @@ -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 diff --git a/src/Diagrams/Backend/SVG.hs b/src/Diagrams/Backend/SVG.hs --- a/src/Diagrams/Backend/SVG.hs +++ b/src/Diagrams/Backend/SVG.hs @@ -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 diff --git a/src/Diagrams/Backend/SVG/CmdLine.hs b/src/Diagrams/Backend/SVG/CmdLine.hs --- a/src/Diagrams/Backend/SVG/CmdLine.hs +++ b/src/Diagrams/Backend/SVG/CmdLine.hs @@ -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 --- . --- +-- . +-- ----------------------------------------------------------------------------- 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 diff --git a/src/Graphics/Rendering/SVG.hs b/src/Graphics/Rendering/SVG.hs --- a/src/Graphics/Rendering/SVG.hs +++ b/src/Graphics/Rendering/SVG.hs @@ -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