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/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,26 @@ -Copyright Felipe Lessa 2011 +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 + Brent Yorgey All rights reserved. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,84 @@ +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]. + +[diagrams]: http://projects.haskell.org/diagrams/ +[haskell]: http://www.haskell.org/haskellwiki/Haskell + +_diagrams-svg_ is the default out-of-the box backend that comes with +the diagrams framework, and supports most features defined in [diagrams-lib]. + +[diagrams-lib]: http://hackage.haskell.org/package/diagrams%2Dlib + +# Installation + +``` +cabal update && cabal install diagrams-svg +``` + +# Usage + +A simple example that uses _diagrams-svg_ to draw a square. + +```haskell +import Diagrams.Prelude +import Diagrams.Backend.SVG.CmdLine + +b1 :: Diagram B +b1 = square 20 # lw 0.002 + +main = mainWith (pad 1.1 b1) +``` + +Save this to file named `Square.hs` and compile this program: + +``` +ghc --make Square.hs +``` + +This will generate an executable which, when run produces an SVG file. Run the +executable with the `--help` option to find out more about how to call it. + +``` +$ ./Square --help +./Square + +Usage: ./Square [-w|--width WIDTH] [-h|--height HEIGHT] [-o|--output OUTPUT] [--loop] [-s|--src ARG] [-i|--interval INTERVAL] + Command-line diagram generation. + +Available options: + -?,--help Show this help text + -w,--width WIDTH Desired WIDTH of the output image + -h,--height HEIGHT Desired HEIGHT of the output image + -o,--output OUTPUT OUTPUT file + -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 +file. + +``` +$ ./Square -o square.svg +``` + +The command above generates the SVG file: + +``` + + + + + + + + + +``` diff --git a/diagrams-svg.cabal b/diagrams-svg.cabal --- a/diagrams-svg.cabal +++ b/diagrams-svg.cabal @@ -1,47 +1,64 @@ Name: diagrams-svg -Version: 0.3.7 +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, CHANGELOG.md Author: Felipe Lessa, Deepak Jois -Maintainer: deepak.jois@gmail.com +Maintainer: diagrams-discuss@googlegroups.com +Bug-reports: http://github.com/diagrams/diagrams-svg/issues Stability: Experimental Category: Graphics Build-type: Simple -Cabal-version: >=1.8 -Description: - This package provides a modular backend for rendering diagrams - created with the diagrams EDSL using SVG. It uses - @blaze-svg@ to be a fast, pure-Haskell backend. - . - More documentation: Github README : - +Cabal-version: >=1.10 +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 @svg-builder@ to be a native + Haskell backend, making it suitable for use on + any platform. + . + The package provides the following modules: + . + * "Diagrams.Backend.SVG.CmdLine" - if you're + just getting started with diagrams, begin here. + . + * "Diagrams.Backend.SVG" - look at this next. + The general API for the SVG backend. + . + Additional documentation can be found in the + README file distributed with the source tarball or + viewable on GitHub: + . Source-repository head type: git - location: http://github.com/deepakjois/diagrams-svg + location: http://github.com/diagrams/diagrams-svg Library Exposed-modules: Diagrams.Backend.SVG Diagrams.Backend.SVG.CmdLine Other-modules: Graphics.Rendering.SVG Hs-source-dirs: src - Build-depends: base >= 4.3 && < 4.6 - , old-time >= 1.0 && < 1.2 - , process >= 1.0 && < 1.2 - , directory >= 1.0 && < 1.2 - , filepath >= 1.2 && < 1.4 - , mtl >= 1 && < 3.0 - , bytestring >= 0.9 && < 1.0 - , vector-space >= 0.7 && < 0.9 - , colour - , diagrams-core >= 0.5.0.1 && < 0.6 - , diagrams-lib >= 0.5 && < 0.6 - , blaze-svg >= 0.3.3 - , cmdargs >= 0.6 && < 0.10 - , split >= 0.1.2 && < 0.2 - if !os(windows) - cpp-options: -DCMDLINELOOP - Build-depends: unix >= 2.4 && < 2.6 + 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 + + Default-language: Haskell2010 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,118 +1,445 @@ -{-# LANGUAGE TypeFamilies - , MultiParamTypeClasses - , FlexibleInstances - , FlexibleContexts - , TypeSynonymInstances - , DeriveDataTypeable - #-} -{-| - The SVG backend. --} +{-# 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 #-} + +---------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.SVG +-- Copyright : (c) 2011-2015 diagrams-svg team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A full-featured rendering backend for diagrams producing SVG files, +-- implemented natively in Haskell (making it easy to use on any +-- platform). +-- +-- To invoke the SVG backend, you have three options. +-- +-- * You can use the "Diagrams.Backend.SVG.CmdLine" module to create +-- standalone executables which output SVG images when invoked. +-- +-- * 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). 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 +-- disk), you can manually invoke the 'renderDia' method from the +-- 'Diagrams.Core.Types.Backend' instance for @SVG@. In particular, +-- 'Diagrams.Core.Types.renderDia' has the generic type +-- +-- > 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, @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@, @v ~ V2@, we have +-- +-- >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 V2 n = R 'SvgRenderM n' +-- @ +-- +-- @ +-- type family Result SVG V2 n = 'Element' +-- @ +-- +-- So the type of 'renderDia' resolves to +-- +-- @ +-- renderDia :: SVG -> Options SVG V2 n -> QDiagram SVG V2 n m -> 'Graphics.Rendering.SVG.Element' +-- @ +-- +-- 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 - , Options(..) -- for rendering options specific to SVG + , B + -- for rendering options specific to SVG + , Options(..), sizeSpec, svgDefinitions, idPrefix, svgAttributes, generateDoctype + , svgClass, svgId, svgTitle, svgAttr + , SVGFloat + + , renderSVG + , renderSVG' + , renderPretty + , renderPretty' + , loadImageSVG ) where +-- 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 Data.Typeable -import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.State +import Data.Char +import Data.Function (on) +import Data.Typeable --- from diagrams-lib -import Diagrams.Prelude -import Diagrams.TwoD.Path (getClip) -import Diagrams.TwoD.Adjust (adjustDia2D) -import Diagrams.TwoD.Text +-- from hashable +import Data.Hashable (Hashable (), hashWithSalt) --- from blaze-svg -import qualified Text.Blaze.Svg11 as S -import Text.Blaze.Svg11 ((!)) +-- from bytestring +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Lazy as BS --- from colour -import Data.Colour (transparent) +-- from lens +import Control.Lens hiding (transform, ( # )) +-- from diagrams-core +import Diagrams.Core.Compile +import Diagrams.Core.Types (Annotation (..), keyVal) + +-- from diagrams-lib +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 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 } +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 +initialSvgRenderState = SvgRenderState 0 0 1 --- Monad to keep track of state when rendering an SVG. --- Currently just keeps a monotonically increasing counter --- for assiging 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 -incrementClipPath :: State SvgRenderState () -incrementClipPath = modify (\(SvgRenderState x) -> SvgRenderState (x + 1)) +runRenderM :: SVGFloat n => T.Text -> SvgRenderM n -> Element +runRenderM o s = flip evalState initialSvgRenderState + $ runReaderT s (initialEnvironment o) -instance Monoid (Render SVG R2) where - mempty = R $ return mempty - (R r1) `mappend` (R r2_) = - R $ do - svg1 <- r1 - svg2 <- r2_ - return (svg1 `mappend` svg2) +instance Semigroup (Render SVG V2 n) where + R r1 <> R r2_ = R $ do + svg1 <- r1 + svg2 <- r2_ + return (svg1 `mappend` svg2) --- renders a element with styles applied as attributes. -renderStyledGroup :: Style v -> (S.Svg -> S.Svg) -renderStyledGroup s = S.g ! R.renderStyles s +instance Monoid (Render SVG V2 n) where + mempty = R $ return mempty +#if !MIN_VERSION_base(4,11,0) + mappend = (<>) +#endif -renderSvgWithClipping :: S.Svg -- Input SVG - -> Style v -- Styles - -> Int -- Clip Path ID - -> S.Svg -- Resulting svg -renderSvgWithClipping svg s id_ = do - R.renderClip (getClip <$> getAttr s) id_ -- Clipping if any - svg -- The diagram +-- Handle clip attributes. +-- +renderSvgWithClipping :: forall n. SVGFloat n + => T.Text + -> Element -- ^ Input SVG + -> Style V2 n -- ^ Styles + -> SvgRenderM n -- ^ Resulting svg -instance Backend SVG R2 where - data Render SVG R2 = R SvgRenderM - type Result SVG R2 = S.Svg - data Options SVG R2 = SVGOptions - { fileName :: String -- ^ the name of the file you want generated - , size :: SizeSpec2D -- ^ The requested size. - } +renderSvgWithClipping prefix svg s = + case op Clip <$> getAttr s of + Nothing -> return svg + Just paths -> renderClips paths + where + renderClips :: [Path V2 n] -> SvgRenderM n + renderClips [] = return svg + renderClips (p:ps) = do + clipPathId += 1 + ident <- use clipPathId + R.renderClip p prefix ident <$> renderClips ps - withStyle _ s _ (R r) = - R $ do - incrementClipPath - clipPathId_ <- gets clipPathId - svg <- r - let styledSvg = renderStyledGroup s ! (R.renderClipPathId s clipPathId_) $ renderSvgWithClipping svg s clipPathId_ - return styledSvg +-- | Create a new texture defs svg element using the style and the current +-- id number, then increment the gradient id number. +fillTextureDefs :: SVGFloat n => Style v n -> SvgRenderM n +fillTextureDefs s = do + ident <- use fillGradId + fillGradId += 2 -- always even + return $ R.renderFillTextureDefs ident s - doRender _ (SVGOptions _ sz) (R r) = - evalState svgOutput initialSvgRenderState - where - svgOutput = do - svg <- r - let (w,h) = case sz of - Width w' -> (w',w') - Height h' -> (h',h') - Dims w' h' -> (w',h') - Absolute -> (100,100) - return $ R.svgHeader w h $ svg +lineTextureDefs :: SVGFloat n => Style v n -> SvgRenderM n +lineTextureDefs s = do + ident <- use lineGradId + lineGradId += 2 -- always odd + return $ R.renderLineTextureDefs ident s - adjustDia c opts d = adjustDia2D size setSvgSize c opts (d # reflectY - # fcA transparent - ) - where setSvgSize sz o = o { size = sz } +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 -instance Renderable (Segment R2) SVG where - render c = render c . flip Trail False . (:[]) + 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 = rtree (splitTextureFills rt) + V2 w h = specToSize 100 (opts^.sizeSpec) + svg <- r + return $ R.svgHeader w h (opts^.svgDefinitions) + (opts^.svgAttributes) + (opts^.generateDoctype) svg -instance Renderable (Trail R2) SVG where - render c t = render c $ Path [(p2 (0,0), t)] + adjustDia c opts d = ( sz, t <> reflectionY, d' ) where + (sz, t, d') = adjustDia2D sizeSpec c opts (d # reflectY) -instance Renderable (Path R2) SVG where - render _ = R . return . R.renderPath +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 -instance Renderable Text SVG where - render _ = R . return . R.renderText +-- | 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" --- TODO: instance Renderable Image SVG where +-- | 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" + +-- | 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" + +-- | 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 + +-- | 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 } + +-- | 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 } + +-- | 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 } + +-- | 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 } + +-- | 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 } + +-- paths --------------------------------------------------------------- + +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 SVGFloat n => Renderable (Path V2 n) SVG where + render _ = R . attributedRender . 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 + + -- 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 + + fillGradDefs <- fillTextureDefs (sty & atAttr %~ adjustTrans) + return $ + fillGradDefs `mappend` g_ (R.renderStyles idFill idLine sty) clippedSvg + +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 :: 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,92 +1,108 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.SVG.CmdLine --- Copyright : (c) 2011 Diagrams team (see LICENSE) +-- Copyright : (c) 2013 Diagrams team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Convenient creation of command-line-driven executables for -- rendering diagrams using the SVG backend. -- +-- * 'defaultMain' creates an executable which can render a single +-- diagram at various options. +-- +-- * 'multiMain' is like 'defaultMain' but allows for a list of +-- diagrams from which the user can choose one to render. +-- +-- * 'mainWith' is a generic form that does all of the above but with +-- a slightly scarier type. See "Diagrams.Backend.CmdLine". This +-- form can also take a function type that has a subtable final result +-- (any of arguments to the above types) and 'Parseable' arguments. +-- +-- If you want to generate diagrams programmatically---/i.e./ if you +-- want to do anything more complex than what the below functions +-- provide---you have several options. +-- +-- * Use a function with 'mainWith'. This may require making +-- 'Parseable' instances for custom argument types. +-- +-- * Make a new 'Mainable' instance. This may require a newtype +-- wrapper on your diagram type to avoid the existing instances. +-- This gives you more control over argument parsing, intervening +-- steps, and diagram creation. +-- +-- * Build option records and pass them along with a diagram to 'mainRender' +-- from "Diagrams.Backend.CmdLine". +-- +-- * You can use 'Diagrams.Backend.SVG.renderSVG' to render a diagram +-- to a file directly; see "Diagrams.Backend.SVG". +-- +-- * A more flexible approach is to directly call 'renderDia'; see +-- "Diagrams.Backend.SVG" for more information. +-- +-- For a tutorial on command-line diagram creation see +-- . +-- ----------------------------------------------------------------------------- module Diagrams.Backend.SVG.CmdLine - ( defaultMain - , multiMain - ) where + ( + -- * General form of @main@ + -- $mainwith -import Diagrams.Prelude hiding (width, height, interval) -import Diagrams.Backend.SVG + mainWith -import System.Console.CmdArgs.Implicit hiding (args) + -- * Supported forms of @main@ -import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) -import qualified Data.ByteString.Lazy as BS + , defaultMain + , multiMain -import Prelude hiding (catch) + -- * Backend tokens -import Data.Maybe (fromMaybe) -import Control.Monad (when) -import Data.List.Split + , SVG + , B + ) where -import System.Environment (getArgs, getProgName) -import System.Directory (getModificationTime) -import System.Process (runProcess, waitForProcess) -import System.IO (openFile, hClose, IOMode(..), - hSetBuffering, BufferMode(..), stdout) -import System.Exit (ExitCode(..)) -import System.Time (ClockTime, getClockTime) -import Control.Concurrent (threadDelay) -import Control.Exception (catch, SomeException(..), bracket) +import Diagrams.Backend.CmdLine +import Diagrams.Backend.SVG +import Diagrams.Prelude hiding (height, interval, output, + width) -#ifdef CMDLINELOOP -import System.Posix.Process (executeFile) -#endif +import Options.Applicative -data DiagramOpts = DiagramOpts - { width :: Maybe Int - , height :: Maybe Int - , output :: FilePath - , selection :: Maybe String -#ifdef CMDLINELOOP - , loop :: Bool - , src :: Maybe String - , interval :: Int -#endif - } - deriving (Show, Data, Typeable) +import Data.List.Split -diagramOpts :: String -> Bool -> DiagramOpts -diagramOpts prog sel = DiagramOpts - { width = def - &= typ "INT" - &= help "Desired width of the output image" +-- $mainwith +-- The 'mainWith' method unifies all of the other forms of @main@ and is +-- now the recommended way to build a command-line diagrams program. It +-- works as a direct replacement for 'defaultMain' or 'multiMain' as well +-- as allowing more general arguments. For example, given a function that +-- produces a diagram when given an @Int@ and a @'Colour' Double@, 'mainWith' +-- will produce a program that looks for additional number and color arguments. +-- +-- > ... definitions ... +-- > f :: Int -> Colour Double -> Diagram SVG V2 Double +-- > f i c = ... +-- > +-- > main = mainWith f +-- +-- 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 - , height = def - &= typ "INT" - &= help "Desired height of the output image" - , output = def - &= typFile - &= help "Output file" - - , selection = def - &= help "Name of the diagram to render" - &= (if sel then typ "NAME" else ignore) -#ifdef CMDLINELOOP - , loop = False - &= help "Run in a self-recompiling loop" - , src = def - &= typFile - &= help "Source file to watch" - , interval = 1 &= typ "SECONDS" - &= help "When running in a loop, check for changes every n seconds." -#endif - } - &= summary "Command-line diagram generation." - &= program prog - -- | This is the simplest way to render diagrams, and is intended to -- be used like so: -- @@ -99,94 +115,86 @@ -- and so on, and renders @myDiagram@ with the specified options. -- -- Pass @--help@ to the generated executable to see all available --- options. -defaultMain :: Diagram SVG R2 -> IO () -defaultMain d = do - prog <- getProgName - args <- getArgs - opts <- cmdArgs (diagramOpts prog False) - chooseRender opts d -#ifdef CMDLINELOOP - when (loop opts) (waitForChange Nothing opts prog args) -#endif +-- options. Currently it looks something like +-- +-- @ +-- ./Program +-- +-- 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: +-- -?,--help Show this help text +-- -w,--width WIDTH Desired WIDTH of the output image +-- -h,--height HEIGHT Desired HEIGHT of the output image +-- -o,--output OUTPUT OUTPUT file +-- -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 +-- +-- @ +-- $ ghc --make MyDiagram +-- +-- # output image.svg with a width of 400pt (and auto-determined height) +-- $ ./MyDiagram -o image.svg -w 400 +-- @ -chooseRender :: DiagramOpts -> Diagram SVG R2 -> IO () -chooseRender opts d = - case splitOn "." (output opts) of - [""] -> putStrLn "No output file given." - ps | last ps `elem` ["svg"] -> do - let sizeSpec = case (width opts, height opts) 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) +defaultMain :: SVGFloat n => QDiagram SVG V2 n Any -> IO () +defaultMain = mainWith - build = renderDia SVG (SVGOptions (output opts) sizeSpec) d - BS.writeFile (output opts) (renderSvg build) - | otherwise -> putStrLn $ "Unknown file type: " ++ last ps +newtype PrettyOpt = PrettyOpt {isPretty :: Bool} +prettyOpt :: Parser PrettyOpt +prettyOpt = PrettyOpt <$> switch (long "pretty" + <> short 'p' + <> help "Pretty print the SVG output") --- | @multiMain@ is like 'defaultMain', except instead of a single --- diagram it takes a list of diagrams paired with names as input. --- The generated executable then takes an argument specifying the --- name of the diagram that should be rendered. This is a --- convenient way to create an executable that can render many --- different diagrams without modifying the source code in between --- each one. -multiMain :: [(String, Diagram SVG R2)] -> IO () -multiMain ds = do - prog <- getProgName - opts <- cmdArgs (diagramOpts prog True) - case selection opts of - Nothing -> putStrLn "No diagram selected." - Just sel -> case lookup sel ds of - Nothing -> putStrLn $ "Unknown diagram: " ++ sel - Just d -> chooseRender opts d +instance Parseable PrettyOpt where + parser = prettyOpt -#ifdef CMDLINELOOP -waitForChange :: Maybe ClockTime -> DiagramOpts -> String -> [String] -> IO () -waitForChange lastAttempt opts prog args = do - hSetBuffering stdout NoBuffering - go lastAttempt - where go lastAtt = do - threadDelay (1000000 * interval opts) - -- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")" - (newBin, newAttempt) <- recompile lastAtt prog (src opts) - if newBin - then executeFile prog False args Nothing - else go $ getFirst (First newAttempt <> First lastAtt) +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 --- | @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 ClockTime -> String -> Maybe String -> IO (Bool, Maybe ClockTime) -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 <- bracket (openFile errFile WriteMode) hClose $ \h -> - waitForProcess =<< runProcess "ghc" ["--make", srcFile] - Nothing Nothing Nothing Nothing (Just h) +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 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 - if (status /= ExitSuccess) - then putStrLn "" >> putStrLn (replicate 75 '-') >> readFile errFile >>= putStr - else putStrLn "done." +-- | @multiMain@ is like 'defaultMain', except instead of a single +-- diagram it takes a list of diagrams paired with names as input. +-- The generated executable then takes a @--selection@ option +-- specifying the name of the diagram that should be rendered. The +-- list of available diagrams may also be printed by passing the +-- option @--list@. +-- +-- Example usage: +-- +-- @ +-- $ ghc --make MultiTest +-- [1 of 1] Compiling Main ( MultiTest.hs, MultiTest.o ) +-- Linking MultiTest ... +-- $ ./MultiTest --list +-- Available diagrams: +-- foo bar +-- $ ./MultiTest --selection bar -o Bar.eps -w 200 +-- @ - curTime <- getClockTime - return (status == ExitSuccess, Just curTime) +multiMain :: SVGFloat n => [(String, QDiagram SVG V2 n Any)] -> IO () +multiMain = mainWith - else return (False, Nothing) +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) - where getModTime f = catch (Just <$> getModificationTime f) - (\(SomeException _) -> return Nothing) -#endif + mainRender = defaultMultiMainRender 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,83 +1,292 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ViewPatterns, OverloadedStrings, RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.SVG +-- Copyright : (c) 2011 diagrams-svg team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Generic tools for generating SVG files. +-- +----------------------------------------------------------------------------- + module Graphics.Rendering.SVG - ( svgHeader + ( SVGFloat + , Element + , AttributeValue + , svgHeader , renderPath , renderClip - , renderClipPathId , renderText + , renderDImage + , renderDImageEmb , renderStyles + , renderMiterLimit + , renderFillTextureDefs + , renderFillTexture + , renderLineTextureDefs + , renderLineTexture + , dataUri + , getNumAttr ) where -- from base -import Data.List (intersperse, intercalate) +import Data.List (intercalate) +#if __GLASGOW_HASKELL__ < 710 +import Data.Foldable (foldMap) +#endif +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 (Render, Attribute, close, e, (<>)) -import Diagrams.TwoD.Text -import Diagrams.TwoD.Path (getFillRule, getClip) +import Diagrams.Prelude hiding (Attribute, Render, with, (<>)) +import Diagrams.TwoD.Path (getFillRule) +import Diagrams.TwoD.Text -import Text.Blaze.Svg11 ((!), mkPath, m, cr, hr, vr, lr, 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 -svgHeader :: Double -> Double -> S.Svg -> S.Svg -svgHeader w h_ 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])) $ - S.g $ s +-- from svg-builder +import Graphics.Svg hiding (renderText) -renderPath :: Path R2 -> S.Svg -renderPath (Path trs) = S.path ! A.d makePath - where - makePath = mkPath $ mapM_ renderTrail trs +-- from base64-bytestring, bytestring +import qualified Data.ByteString.Base64.Lazy as BS64 +import qualified Data.ByteString.Lazy.Char8 as BS8 -renderTrail :: (P2, Trail R2) -> S.Path -renderTrail (unp2 -> (x,y), Trail segs closed) = do - m x y - mapM_ renderSeg segs - if closed then z else return () +-- from JuicyPixels +import Codec.Picture -renderSeg :: Segment R2 -> S.Path -renderSeg (Linear (unr2 -> (x,0))) = hr x -renderSeg (Linear (unr2 -> (0,y))) = vr y -renderSeg (Linear (unr2 -> (x,y))) = lr x y -renderSeg (Cubic (unr2 -> (x0,y0)) (unr2 -> (x1,y1)) (unr2 -> (x2,y2))) = cr x0 y0 x1 y1 x2 y2 +-- | 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 -renderClip :: Maybe [Path R2] -> Int -> S.Svg -renderClip Nothing _ = mempty -renderClip (Just pths) id_ = S.clippath ! A.id_ clipPathId $ renderClipPaths - where renderClipPaths = mapM_ renderPath pths - clipPathId = S.toValue $ "myClip" ++ show id_ +getNumAttr :: AttributeClass (a n) => (a n -> t) -> Style v n -> Maybe t +getNumAttr f = (f <$>) . getAttr --- FIXME take alignment into account -renderText :: Text -> S.Svg -renderText (Text tr _ str) = - S.text_ - ! A.transform transformMatrix - ! A.dominantBaseline "middle" - ! A.textAnchor "middle" - ! A.stroke "none" $ - S.toMarkup str - where - t = tr `mappend` reflectionY - (a,b,c,d,e,f) = getMatrix t - transformMatrix = S.matrix a b c d e f +-- | @svgHeader w h defs s@: @w@ width, @h@ height, +-- @defs@ global definitions for defs sections, @s@ actual SVG content. +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 -getMatrix :: Transformation R2 -> (Double, Double, Double, Double, Double, Double) -getMatrix t = (a1,a2,b1,b2,c1,c2) +renderPath :: SVGFloat n => Path V2 n -> Element +renderPath trs = if makePath == T.empty then mempty else path_ [D_ <<- makePath] + where + makePath = foldMap renderTrail (op Path trs) + +renderTrail :: SVGFloat n => Located (Trail V2 n) -> AttributeValue +renderTrail (viewLoc -> (P (V2 x y), t)) = + mA x y <> withTrail renderLine renderLoop t + where + renderLine = foldMap renderSeg . lineSegments + renderLoop lp = + case loopSegments lp of + -- let z handle the last segment if it is linear + (segs, Linear _) -> foldMap renderSeg segs + + -- otherwise we have to emit it explicitly + _ -> foldMap renderSeg (lineSegments . cutLoop $ lp) + <> z + +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 :: 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 :: SVGFloat n => GradientStop n -> Element +renderStop (GradientStop c v) + = stop_ [ Stop_color_ <<- (colorToRgbText c) + , Offset_ <<- (toText v) + , Stop_opacity_ <<- (toText $ colorToOpacity c) ] + +spreadMethodText :: SpreadMethod -> AttributeValue +spreadMethodText GradPad = "pad" +spreadMethodText GradReflect = "reflect" +spreadMethodText GradRepeat = "repeat" + +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 + 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 :: 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 + 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 + [] -> [] + 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 :: SVGFloat n => Int -> Style v n -> Element +renderFillTextureDefs i s = + 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 :: 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 $ colorToRgbText c + fillColorOpacity = Just $ colorToOpacity c + Just (LG _) -> [Fill_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Fill_opacity_ <<- "1"] + Just (RG _) -> [Fill_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Fill_opacity_ <<- "1"] + Nothing -> [] + +renderLineTextureDefs :: SVGFloat n => Int -> Style v n -> Element +renderLineTextureDefs i s = + case getNumAttr getLineTexture s of + Just (LG g) -> defs_ [] $ renderLinearGradient g i + Just (RG g) -> defs_ [] $ renderRadialGradient g i + _ -> mempty + +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 $ colorToRgbText c + lineColorOpacity = Just $ colorToOpacity c + Just (LG _) -> [Stroke_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Stroke_opacity_ <<- "1"] + Just (RG _) -> [Stroke_ <<- ("url(#gradient" <> (pack . show $ ident) + <> ")"), Stroke_opacity_ <<- "1"] + Nothing -> [] + +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 + img = case encodeDynamicPng dImg of + Left str -> error str + Right img' -> img' + +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 :: SVGFloat n => Text n -> Element +renderText (Text tt tAlign str) = + text_ + [ Transform_ <<- transformMatrix + , Dominant_baseline_ <<- vAlign + , Text_anchor_ <<- hAlign + , Stroke_ <<- "none" ] + $ toElement str where - (unr2 -> (a1,a2)) = apply t unitX - (unr2 -> (b1,b2)) = apply t unitY - (unr2 -> (c1,c2)) = transl t + vAlign = case tAlign of + BaselineText -> "alphabetic" + BoxAlignedText _ h -> case h of -- A mere approximation + h' | h' <= 0.25 -> "text-after-edge" + h' | h' >= 0.75 -> "text-before-edge" + _ -> "middle" + hAlign = case tAlign of + BaselineText -> "start" + BoxAlignedText w _ -> case w of -- A mere approximation + w' | w' <= 0.25 -> "start" + w' | w' >= 0.75 -> "end" + _ -> "middle" + t = tt `mappend` reflectionY + [[a,b],[c,d],[e,f]] = matrixHomRep t + transformMatrix = matrix a b c d e f -renderStyles :: forall v. Style v -> S.Attribute -renderStyles s = mconcat . map ($ s) $ - [ renderLineColor - , renderFillColor +renderStyles :: SVGFloat n => Int -> Int -> Style v n -> [Attribute] +renderStyles fillId lineId s = concatMap ($ s) $ + [ renderLineTexture lineId + , renderFillTexture fillId , renderLineWidth , renderLineCap , renderLineJoin @@ -88,123 +297,113 @@ , renderFontSlant , renderFontWeight , renderFontFamily - ] - -renderLineColor :: Style v -> S.Attribute -renderLineColor s = - (renderAttr A.stroke lineColorRgb) `mappend` - (renderAttr A.strokeOpacity lineColorOpacity) - where lineColor_ = getLineColor <$> getAttr s - lineColorRgb = colorToRgbString <$> lineColor_ - lineColorOpacity = colorToOpacity <$> lineColor_ - -renderFillColor :: Style v -> S.Attribute -renderFillColor s = - (renderAttr A.fill fillColorRgb) `mappend` - (renderAttr A.fillOpacity fillColorOpacity) - where fillColor_ = getFillColor <$> getAttr s - fillColorRgb = colorToRgbString <$> fillColor_ - fillColorOpacity = colorToOpacity <$> fillColor_ + , renderMiterLimit ] +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 +renderOpacity :: Style v n -> [Attribute] +renderOpacity s = renderAttr Opacity_ o + where o = 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" +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 :: Style v -> S.Attribute -renderLineWidth s = renderAttr A.strokeWidth lineWidth_ - where lineWidth_ = getLineWidth <$> getAttr s +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 offset) +renderDashing :: SVGFloat n => Style v n -> [Attribute] +renderDashing s = renderTextAttr Stroke_dasharray_ arr <> + renderAttr Stroke_dashoffset_ dOffset where getDasharray (Dashing a _) = a - getDashoffset :: Dashing -> Double getDashoffset (Dashing _ o) = o - dashArrayToStr = intercalate "," . map show - dashing_ = getDashing <$> getAttr s - arr = (dashArrayToStr . getDasharray) <$> dashing_ - offset = getDashoffset <$> dashing_ + 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") . show . getFontSize) <$> getAttr s + 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_ - where - fontFamily_ = getFont <$> getAttr s -renderClipPathId :: Style v -> Int -> S.Attribute -renderClipPathId s id_ = renderAttr A.clipPath clipPathId +renderFontFamily :: Style v n -> [Attribute] +renderFontFamily s = renderTextAttr Font_family_ ff where - clipPathId :: Maybe String - clipPathId = case getClip <$> getAttr s of - Nothing -> Nothing - Just _ -> Just ("url(#myClip" ++ show id_ ++ ")") + 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 +-- | Render a style attribute if available, empty otherwise. +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,_) = colorToRGBA 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 - where (_,_,_,a) = colorToRGBA c - + where (_,_,_,a) = colorToSRGBA c