diagrams-svg 0.3.7 → 1.5
raw patch · 7 files changed
Files
- CHANGELOG.md +521/−0
- LICENSE +23/−1
- README.md +84/−0
- diagrams-svg.cabal +46/−29
- src/Diagrams/Backend/SVG.hs +415/−88
- src/Diagrams/Backend/SVG/CmdLine.hs +155/−147
- src/Graphics/Rendering/SVG.hs +345/−146
+ CHANGELOG.md view
@@ -0,0 +1,521 @@+## [v1.5](https://github.com/diagrams/diagrams-svg/tree/v1.5) (2025-03-25)++- Allow `base-4.21` and test on GHC 9.12+- Allow `diagrams-lib-1.5` and remove `DiagramLoopOpts` which is no+ longer supported++## [v1.4.4](https://github.com/diagrams/diagrams-svg/tree/v1.4.4) (2025-03-05)++- New `svgAttr` function, for adding arbitrary attribute/value pairs+ to nodes. Thanks to @Chobbes for the [PR](https://github.com/diagrams/diagrams-svg/pull/124).++## [v1.4.3.2](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.2) (2024-08-27)++- Allow `hashable-1.5`+- Fix `examples/opts.hs` (thanks to @PiotrJustyna)++## [v1.4.3.1-r7](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r7) (2024-07-02)++- Allow `filepath-1.5`, `containers-0.7`, and `lens-5.3`+- Test on GHC 9.10++## [v1.4.3.1-r6](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r6) (2024-01-20)++- Allow `base-4.19` and `text-2.1`+- Test on GHC 9.8++## [v1.4.3.1-r5](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r5) (2023-05-30)++- Allow `base-4.18`, `mtl-2.3`, `optparse-applicative-0.18`, and test on GHC 9.6++## [v1.4.3.1-r4](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r4) (2022-09-05)++- Allow `base-4.17`, `lens-5.2`, and test on GHC 9.4++## [v1.4.3.1-r3](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r3) (2022-02-02)++- Allow `optparse-applicative-0.17`.++## [v1.4.3.1-r2](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1-r2) (2022-01-10)++- Allow `text-2.0`.++## [v1.4.3.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.3.1) (2021-12-28)++- Dependency upper bounds updates to allow:+ - `base-4.16` (GHC 9.2)+ - `lens-5.1`+ - `hashable-1.4`+ - `semigroups-0.20`+- Add `Eq` instance for `Options SVG` and (orphan) `Eq` instance for `Element`++## [v1.4.3-r3](https://github.com/diagrams/diagrams-svg/tree/v1.4.3-r3) (2021-06-08)++Dependency upper bounds updates, to allow:++- `base-4.15` (GHC 9.0)+- `base64-bytestring-1.2`+- `diagrams-core-1.5`+- `monoid-extras-0.6`+- `lens-5.0`+- `optparse-applicative-0.16`++## [v1.4.3](https://github.com/diagrams/diagrams-svg/tree/v1.4.3) (2019-12-10)++- Allow `base-4.13` (GHC 8.8), `lens-4.18`, `semigroups-0.19`,+ `hashable-1.3`, `optparse-applicative-0.15`+- Stop rounding the coordinates of the viewbox+ ([#109](https://github.com/diagrams/diagrams-svg/issues/109))+- New `svgClass`, `svgId`, and `svgTitle` functions for setting SVG+ attributes via annotations++## [v1.4.2](https://github.com/diagrams/diagrams-svg/tree/v1.4.2) (2018-05-09)++- Allow `base-4.11` (GHC 8.4) and `lens-4.16`+- Add `Semigroup (Render SVG V2 n)` instance++## [v1.4.1.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.1.1) (2017-08-23)++- Allow `base-4.10` and `optparse-applicative-0.14`+- Fix gradients applied to text ([#98](https://github.com/diagrams/diagrams-svg/issues/98))++## [v1.4.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.1) (2016-10-26)++- Handle wider range of font weight specifications+- allow `lens-4.15`++## [v1.4.0.4](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.4) (2016-08-22)++- Require `optparse-applicative-0.13`, and fix compilation error++## [v1.4.0.3](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.3) (2016-08-16)++- Allow `optparse-applicative-0.13`++## [v1.4.0.2](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.2) (2016-06-06)++- allow `base-4.9`+- test with GHC 8.0+- minor documentation updates++## [v1.4.0.1](https://github.com/diagrams/diagrams-svg/tree/v1.4.0.1) (2016-05-01)++- allow `lens-4.14`++## [v1.4](https://github.com/diagrams/diagrams-svg/tree/v1.4) (2016-02-14)++-- Changes for `svg-builder`+-- Deprecate `svgId` and `svgClass`++## [v1.3.1.8](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.8) (2015-11-14)++- allow `lucid-svg-0.6`++## [v1.3.1.7](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.7) (2015-11-10)++- allow `semigroups-0.18`++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.6...v1.3.1.7)++## [v1.3.1.6](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.6) (2015-09-29)++- allow `optparse-applicative-0.12`++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.5...v1.3.1.6)+++## [v1.3.1.5](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.5) (2015-09-19)++- allow `lens-4.13` and `semigroups-0.17`++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.4...v1.3.1.5)++## [v1.3.1.4](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.4) (2015-07-19)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.3...v1.3.1.4)++## [v1.3.1.3](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.2) (2015-07-09)++- Changes to allow `lucid-svg-0.5`++## [v1.3.1.2](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.2) (2015-05-26)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.3.1.1...v1.3.1.2)++## [v1.3.1.1](https://github.com/diagrams/diagrams-svg/tree/v1.3.1.1) (2015-05-06)++**Bug Fix**: handle empty dashing array properly ([\#80](https://github.com/diagrams/diagrams-svg/pull/80))++## [v1.3.1](https://github.com/diagrams/diagrams-svg/tree/v1.3.1) (2015-04-30)++**API Changes**++ - Type of `SVGOptions` changed. `_svgDefinitions :: Maybe SvgM`++**Internal Changes**++ - Use `ReaderT` for styles++## [v1.3](https://github.com/diagrams/diagrams-svg/tree/v1.3) (2015-04-19)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.4...v1.1.0.5)++**New features**++- User settable ID prefixes++- Support opacity group++- Fix clipping bug (Issue #70)++**Internal Changes**++- Switch rendering engine from `blaze-svg` to `lucid-svg`++- Use `fsnotify` for looping++- Add defs tags for clips and gradients++**Implemented enhancements:**++- Put `clip path`, `gradients`, etc in defs tag. [\#73](https://github.com/diagrams/diagrams-svg/issues/73)++**Fixed bugs:**++- Font size not applied properly in composite diagram [\#66](https://github.com/diagrams/diagrams-svg/issues/66)++- clipping broken [\#70](https://github.com/diagrams/diagrams-svg/issues/70)++**Merged pull requests:**++- State [\#74](https://github.com/diagrams/diagrams-svg/pull/74) ([cchalmers](https://github.com/cchalmers))++- Bump base upper bound [\#72](https://github.com/diagrams/diagrams-svg/pull/72) ([bgamari](https://github.com/bgamari))++- Allow user to set ID prefixes [\#71](https://github.com/diagrams/diagrams-svg/pull/71) ([mightybyte](https://github.com/mightybyte))++- Lucid [\#69](https://github.com/diagrams/diagrams-svg/pull/69) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Use fsnotify for looping, via diagrams-lib [\#67](https://github.com/diagrams/diagrams-svg/pull/67) ([bergey](https://github.com/bergey))++## [v1.1.0.5](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.5) (2015-04-03)++- allow `lens-4.9`++- allow `vector-space-0.10`++- allow `blaze-markup-0.7`++## [v1.1.0.4](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.4) (2015-01-13)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.3...v1.1.0.4)++## [v1.1.0.3](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.3) (2014-12-07)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.2...v1.1.0.3)++## [v1.1.0.2](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.2) (2014-11-17)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1.0.1...v1.1.0.2)++**Fixed bugs:**++- Font scaling uses "em" units. [\#30](https://github.com/diagrams/diagrams-svg/issues/30)++**Merged pull requests:**++- Bump lens upper version bounds [\#65](https://github.com/diagrams/diagrams-svg/pull/65) ([RyanGlScott](https://github.com/RyanGlScott))++- New stuff [\#63](https://github.com/diagrams/diagrams-svg/pull/63) ([cchalmers](https://github.com/cchalmers))++- Allows us to write `Diagram B` instead of `Diagram B V2 Double/Float/Whatever` in diagrams programs [\#62](https://github.com/diagrams/diagrams-svg/pull/62) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Linear [\#61](https://github.com/diagrams/diagrams-svg/pull/61) ([cchalmers](https://github.com/cchalmers))++## [v1.1.0.1](https://github.com/diagrams/diagrams-svg/tree/v1.1.0.1) (2014-08-22)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.1...v1.1.0.1)++**Closed issues:**++- Embedding JPEG images without repacking [\#57](https://github.com/diagrams/diagrams-svg/issues/57)++**Merged pull requests:**++- Enable compilation with GHC HEAD \(v7.9\) [\#60](https://github.com/diagrams/diagrams-svg/pull/60) ([ggreif](https://github.com/ggreif))++- Add loadImageSVG to support JPEG-images without repacking via Native DImages [\#58](https://github.com/diagrams/diagrams-svg/pull/58) ([taruti](https://github.com/taruti))++- Allow svg output file to be pretty printed [\#56](https://github.com/diagrams/diagrams-svg/pull/56) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++## [v1.1](https://github.com/diagrams/diagrams-svg/tree/v1.1) (2014-06-02)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.2.1...v1.1)++**New features**++- Support for radial and linear gradients.++- Support for embedded images in `.png` format.++**New instances**++- `Renderable` instances for `DImage Embedded`.++**API changes**++- Updates to work with `Measure` units.++- Substantial refactoring of `Backend` instance to support changes in+ `Diagrams.Core`.++**Dependency/version changes**++- New dependencies: `base64-bytestring` and `JuicyPixels`.++- Allow `lens-4.2`++- Allow `mtl-2.2`++**Closed issues:**++- Support hyperlinks [\#48](https://github.com/diagrams/diagrams-svg/issues/48)++- Line width not handled properly by some browsers [\#33](https://github.com/diagrams/diagrams-svg/issues/33)++- implement image embedding [\#11](https://github.com/diagrams/diagrams-svg/issues/11)++**Merged pull requests:**++- Embedded images - png working [\#54](https://github.com/diagrams/diagrams-svg/pull/54) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- fix text scaling [\#53](https://github.com/diagrams/diagrams-svg/pull/53) ([byorgey](https://github.com/byorgey))++- Updates to work with `Backend` redesign [\#51](https://github.com/diagrams/diagrams-svg/pull/51) ([byorgey](https://github.com/byorgey))++- Rework of units [\#50](https://github.com/diagrams/diagrams-svg/pull/50) ([byorgey](https://github.com/byorgey))++- Preliminary implementation of Measure [\#46](https://github.com/diagrams/diagrams-svg/pull/46) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Gradient [\#41](https://github.com/diagrams/diagrams-svg/pull/41) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++## [v1.0.2.1](https://github.com/diagrams/diagrams-svg/tree/v1.0.2.1) (2014-03-19)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.2...v1.0.2.1)++## [v1.0.2](https://github.com/diagrams/diagrams-svg/tree/v1.0.2) (2014-03-09)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1.3...v1.0.2)++**New features**++- Support for including hyperlinks.++**Dependency/version changes**++- Allow `diagrams-core-1.1` and `diagrams-lib-1.1`++- Allow `lens-4.0`++**Bug fixes**+++- Use `splitFills` to properly render certain diagrams with mixed+ lines and filled loops. Previously, in certain situations loops that should+ have been filled were not. ([#43](https://github.com/diagrams/diagrams-svg/issues/43))++- Don't emit last segment of a loop if it is linear.++ See [diagrams-cairo#38](http://github.com/diagrams/diagrams-cairo/issues/38). This wasn't actually causing any+ observable problems in the SVG backend output, but this seems a+ better/more robust way to do things in any case.++**Closed issues:**++- SVG backend doesn't fill loops if they occur in the same subtree as a line [\#43](https://github.com/diagrams/diagrams-svg/issues/43)++**Merged pull requests:**++- Hyperlinks [\#49](https://github.com/diagrams/diagrams-svg/pull/49) ([tdox](https://github.com/tdox))++- stop using ignoreFill; use splitFills instead. Fixes \#43. [\#47](https://github.com/diagrams/diagrams-svg/pull/47) ([byorgey](https://github.com/byorgey))++## [v1.0.1.3](https://github.com/diagrams/diagrams-svg/tree/v1.0.1.3) (2014-02-06)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1.2...v1.0.1.3)++## [v1.0.1.2](https://github.com/diagrams/diagrams-svg/tree/v1.0.1.2) (2014-02-04)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1.1...v1.0.1.2)++## [v1.0.1.1](https://github.com/diagrams/diagrams-svg/tree/v1.0.1.1) (2014-01-30)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0.1...v1.0.1.1)++## [v1.0.1](https://github.com/diagrams/diagrams-svg/tree/v1.0.1) (2014-01-26)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v1.0...v1.0.1)++**Merged pull requests:**++- Add Hashable instance for Options SVG R2 [\#45](https://github.com/diagrams/diagrams-svg/pull/45) ([byorgey](https://github.com/byorgey))++## [v1.0](https://github.com/diagrams/diagrams-svg/tree/v1.0) (2013-11-25)++According to the PVP, these changes should require a major version+bump. However, a major version bump would be quite annoying and I+don't expect these instance changes to affect anyone (the changes+were made for internal reasons). Please yell if it does affect+you.++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.8.0.2...v1.0)++**Fixed bugs:**++- SVG backend fills lines again [\#42](https://github.com/diagrams/diagrams-svg/issues/42)++## [v0.8.0.2](https://github.com/diagrams/diagrams-svg/tree/v0.8.0.2) (2013-10-26)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.8.0.1...v0.8.0.2)++**Closed issues:**++- Text alignment support [\#17](https://github.com/diagrams/diagrams-svg/issues/17)++- Add a workaround for the Chrome stroke-width 0 bug [\#3](https://github.com/diagrams/diagrams-svg/issues/3)++**Merged pull requests:**++- Lens [\#40](https://github.com/diagrams/diagrams-svg/pull/40) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth))++- Updating information about 'Options SVG' [\#39](https://github.com/diagrams/diagrams-svg/pull/39) ([co-dan](https://github.com/co-dan))++## [v0.8.0.1](https://github.com/diagrams/diagrams-svg/tree/v0.8.0.1) (2013-09-11)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.8...v0.8.0.1)++## [v0.8](https://github.com/diagrams/diagrams-svg/tree/v0.8) (2013-09-10)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.7...v0.8)++**New features**++- Extra SVG definitions, to be inserted in the output, may be+ passed as an argument++- Support for new miter limit attribute++- Approximate text alignment++**Bug fixes**++- Stacking multiple clip regions now works properly++**Merged pull requests:**++- Font embedding changes [\#38](https://github.com/diagrams/diagrams-svg/pull/38) ([jbracker](https://github.com/jbracker))++- Added approximation of text alignment. Better then nothing... [\#36](https://github.com/diagrams/diagrams-svg/pull/36) ([jbracker](https://github.com/jbracker))++## [v0.7](https://github.com/diagrams/diagrams-svg/tree/v0.7) (2013-08-09)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.6.0.1...v0.7)++**New features**++- New `renderToSVG` convenience function++- Vastly improved Haddock documentation++**New instances**++- `Show` instance for `Options SVG R2`++**Dependency/version changes**++- allow `base-4.7` and `unix-2.7`++- Upgrade to `monoid-extras-0.3`++**Implemented enhancements:**++- Improve Haddock documentation [\#27](https://github.com/diagrams/diagrams-svg/issues/27)++**Fixed bugs:**++- Lines should not be filled [\#35](https://github.com/diagrams/diagrams-svg/issues/35)++**Closed issues:**++- diagrams-svg.cabal out of sync with core and lib [\#34](https://github.com/diagrams/diagrams-svg/issues/34)++- Add function of type FilePath -\> SizeSpec2D -\> Diagram -\> IO \(\) [\#28](https://github.com/diagrams/diagrams-svg/issues/28)++**Merged pull requests:**++- General SVG backend cleanup, additional documentation, and new API function [\#29](https://github.com/diagrams/diagrams-svg/pull/29) ([byorgey](https://github.com/byorgey))++## [v0.6.0.1](https://github.com/diagrams/diagrams-svg/tree/v0.6.0.1) (2012-12-14)++[Full Changelog](https://github.com/diagrams/diagrams-svg/compare/v0.6...v0.6.0.1)++## [v0.6](https://github.com/diagrams/diagrams-svg/tree/v0.6) (2012-12-12)++First "officially supported" release.++Features still not implemented:++- text alignment++- inline images++As of this release everything else Should Work (tm).++**Closed issues:**++- Line width does not follow specification? [\#24](https://github.com/diagrams/diagrams-svg/issues/24)++- diagrams-svg doesn't build under directory-1.2 \(and hence GHC-7.6\) [\#20](https://github.com/diagrams/diagrams-svg/issues/20)++- Freezing does not appear to work with the SVG backend [\#19](https://github.com/diagrams/diagrams-svg/issues/19)++- Font family support [\#18](https://github.com/diagrams/diagrams-svg/issues/18)++- Fill color needs to be explicitly specified for text nodes [\#15](https://github.com/diagrams/diagrams-svg/issues/15)++- Implement clipping [\#14](https://github.com/diagrams/diagrams-svg/issues/14)++- Add README, documentation and generate documentation on Hackage [\#13](https://github.com/diagrams/diagrams-svg/issues/13)++- implement text attributes [\#10](https://github.com/diagrams/diagrams-svg/issues/10)++- implement text rendering [\#9](https://github.com/diagrams/diagrams-svg/issues/9)++- implement line cap [\#8](https://github.com/diagrams/diagrams-svg/issues/8)++- implement line dashing [\#7](https://github.com/diagrams/diagrams-svg/issues/7)++- Implement line join attribute [\#6](https://github.com/diagrams/diagrams-svg/issues/6)++- Implement opacity [\#5](https://github.com/diagrams/diagrams-svg/issues/5)++- Implement fill rule [\#4](https://github.com/diagrams/diagrams-svg/issues/4)++- Switch to using blaze-svg combinators [\#2](https://github.com/diagrams/diagrams-svg/issues/2)++- Create a new branch for using blaze-svg [\#1](https://github.com/diagrams/diagrams-svg/issues/1)++**Merged pull requests:**++- Fix for clipping with freeze support. [\#26](https://github.com/diagrams/diagrams-svg/pull/26) ([fryguybob](https://github.com/fryguybob))++- Apply frozen transformations with <g\> element. [\#25](https://github.com/diagrams/diagrams-svg/pull/25) ([cmears](https://github.com/cmears))++- ghc-7.6 [\#23](https://github.com/diagrams/diagrams-svg/pull/23) ([michaelt](https://github.com/michaelt))++- Increase cmdargs upper bound to < 0.10 [\#16](https://github.com/diagrams/diagrams-svg/pull/16) ([byorgey](https://github.com/byorgey))++- Line join + cap [\#12](https://github.com/diagrams/diagrams-svg/pull/12) ([byorgey](https://github.com/byorgey))+++\* *This Change Log was automatically generated by (and hand edited) [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)*
LICENSE view
@@ -1,4 +1,26 @@-Copyright Felipe Lessa 2011+Copyright 2011-2016 diagrams-svg team:++ Doug Beardsley <mightybyte@gmail.com>+ Daniel Bergey <bergey@alum.mit.edu>+ Jan Bracker <jan.bracker@googlemail.com>+ Christopher Chalmers <c.chalmers@me.com>+ Michael Chavinda <mchavinda@colgate.edu>+ Tad Doxsee <doxsee@pacbell.net>+ Daniil Frumin <difrumin@gmail.com>+ Ben Gamari <bgamari.foss@gmail.com>+ Gabor Greif <ggreif@gmail.com>+ Deepak Jois <deepak.jois@gmail.com>+ Sidharth Kapur <sidharthkapur1@gmail.com>+ Taru Karttunen <taruti@taruti.net>+ Felipe Lessa <felipe.lessa@gmail.com>+ Andrew Martin <andrew.thaddeus@gmail.com>+ Chris Mears <chris@cmears.id.au>+ Jeffrey Rosenbluth <Jeffrey.Rosenbluth@gmail.com>+ Ryan Scott <ryan.gl.scott@ku.edu>+ Michael Sloan <mgsloan@gmail.com>+ Michael Thompson <what_is_it_to_do_anything@yahoo.com>+ Ryan Yates <fryguybob@gmail.com>+ Brent Yorgey <byorgey@cis.upenn.edu> All rights reserved.
+ README.md view
@@ -0,0 +1,84 @@+diagrams-svg [](https://hackage.haskell.org/package/diagrams-svg) [)](https://github.com/diagrams/diagrams-svg/actions/workflows/haskell-ci.yml)+------------+++_diagrams-svg_ is a an SVG backend for [diagrams]. Diagrams is a powerful,+flexible, declarative domain-specific language for creating vector graphics,+using the [Haskell programming language][haskell].++[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:++```+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+ "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" width="22.0" height="22.0" viewBox="0 0 22 22">+ <g>+ <g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="0.0" stroke-width="2.0e-3">+ <path d="M 21.0,21.0 l -2.220446049250313e-15,-20.0 h -20.0 l -2.220446049250313e-15,20.0 Z" />+ </g>+ </g>+</svg>+```
diagrams-svg.cabal view
@@ -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 : <https://github.com/deepakjois/diagrams-svg/blob/master/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:+ <https://github.com/diagrams/diagrams-svg/blob/master/README.md>. 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
src/Diagrams/Backend/SVG.hs view
@@ -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 <g> 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
src/Diagrams/Backend/SVG/CmdLine.hs view
@@ -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+-- <https://diagrams.github.io/doc/cmdline.html>.+-- ----------------------------------------------------------------------------- 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
src/Graphics/Rendering/SVG.hs view
@@ -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