diagrams-input (empty) → 0.1
raw patch · 11 files changed
+3899/−0 lines, 11 filesdep +JuicyPixelsdep +attoparsecdep +basesetup-changed
Dependencies added: JuicyPixels, attoparsec, base, base64-bytestring, blaze-builder, blaze-markup, bytestring, colour, conduit, conduit-extra, containers, css-text, data-default, diagrams-core, diagrams-lib, digits, either, linear, resourcet, semigroups, split, system-filepath, text, transformers, unordered-containers, vector, xml-conduit, xml-types
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- diagrams-input.cabal +56/−0
- src/Diagrams/SVG/Arguments.hs +649/−0
- src/Diagrams/SVG/Attributes.hs +1013/−0
- src/Diagrams/SVG/Fonts/CharReference.hs +57/−0
- src/Diagrams/SVG/Fonts/ReadFont.hs +190/−0
- src/Diagrams/SVG/Path.hs +264/−0
- src/Diagrams/SVG/ReadSVG.hs +1036/−0
- src/Diagrams/SVG/Tree.hs +547/−0
- src/Diagrams/TwoD/Input.hs +55/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2014, Tillmann Vogt++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Thomas M. DuBuisson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ diagrams-input.cabal view
@@ -0,0 +1,56 @@+Name: diagrams-input+Version: 0.1+Synopsis: Parse raster and SVG files for diagrams+Description: Parse raster and SVG images for the diagrams DSL.+License: BSD3+License-file: LICENSE+Author: Tillmann Vogt+Maintainer: diagrams-discuss@googlegroups.com+Copyright: Tillmann Vogt (2014)+Category: Graphics, Diagrams+Build-type: Simple+Cabal-version: >=1.10+tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.1+Source-repository head+ type: git+ location: http://github.com/diagrams/diagrams-input.git++Library+ Exposed-modules: Diagrams.TwoD.Input+ Diagrams.SVG.ReadSVG+ Diagrams.SVG.Arguments+ Diagrams.SVG.Attributes+ Diagrams.SVG.Path+ Diagrams.SVG.Tree+ Other-modules: Diagrams.SVG.Fonts.CharReference+ Diagrams.SVG.Fonts.ReadFont+ Build-depends: attoparsec >= 0.10+ , base == 4.*+ , base64-bytestring+ , blaze-builder+ , blaze-markup+ , bytestring+ , colour+ , conduit+ , conduit-extra+ , containers+ , css-text+ , data-default+ , diagrams-core >= 1.3 && < 1.6+ , diagrams-lib >= 1.3 && < 1.5+ , digits+ , either >= 4.4+ , JuicyPixels >= 3.1.5 && < 3.4+ , linear >= 1.11.3+ , resourcet+ , semigroups+ , split+ , system-filepath+ , text >= 0.11+ , transformers+ , unordered-containers+ , vector+ , xml-conduit >= 1.3+ , xml-types == 0.3.*+ Hs-source-dirs: src+ default-language: Haskell2010
+ src/Diagrams/SVG/Arguments.hs view
@@ -0,0 +1,649 @@+{-# LANGUAGE OverloadedStrings #-}++module Diagrams.SVG.Arguments+ (+ -- * Attribute Parsing of classes of attributes+ coreAttributes+ , conditionalProcessingAttributes+ , documentEventAttributes+ , graphicalEventAttributes+ , presentationAttributes+ , filterPrimitiveAttributes+ , xlinkAttributes+ , xmlnsNameSpaces+ -- * Attributes for basic structure elements+ , svgAttrs+ , gAttrs+ , sAttrs+ , descAttrs+ , symbolAttrs+ , useAttrs+ , switchAttrs+ -- * Attributes for basic shape elements+ , rectAttrs+ , circleAttrs+ , ellipseAttrs+ , lineAttrs+ , polygonAttrs+ , pathAttrs+ -- * Other Attributes+ , clipPathAttrs+ , patternAttrs+ , imageAttrs+ , filterAttrs+ , linearGradAttrs+ , radialGradAttrs+ , setAttrs+ , stopAttrs+ , textAttrs+ , tspanAttrs+ , namedViewAttrs+ , perspectiveAttrs+ -- * Font Attributes+ , fontAttrs+ , fontFaceAttrs+ , glyphAttrs+ , missingGlyphAttrs+ , kernAttrs+ -- * Filter Effect Attributes+ , feBlendAttrs+ , feColorMatrixAttrs+ , feComponentTransferAttrs+ , feCompositeAttrs+ , feConvolveMatrixAttrs+ , feDiffuseLightingAttrs+ , feDisplacementMapAttrs+ , feFloodAttrs+ , feGaussianBlurAttrs+ , feImageAttrs+ , feMergeAttrs+ , feMorphologyAttrs+ , feOffsetAttrs+ , feSpecularLightingAttrs+ , feTileAttrs+ , feTurbulenceAttrs+ )+where+import Text.XML.Stream.Parse+import Diagrams.SVG.Attributes++coreAttributes =+ do l <- mapM attr+ [ "id", "base", "lang", "space"] -- "xml:base", "xml:lang", "xml:space"]+ return $ (\[a,b,c,d] -> CA a b c d) l++conditionalProcessingAttributes =+ do l <- mapM attr+ [ "requiredFeatures", "requiredExtensions", "systemLanguage"]+ return $ (\[a,b,c] -> CPA a b c) l++documentEventAttributes =+ do l <- mapM attr+ [ "onunload", "onabort", "onerror", "onresize", "onscroll", "onzoom"]+ return $ (\[a,b,c,d,e,f] -> DEA a b c d e f) l++graphicalEventAttributes =+ do l <- mapM attr+ [ "onfocusin", "onfocusout", "onactivate", "onclick", "onmousedown", "onmouseup", + "onmouseover", "onmousemove", "onmouseout", "onload"]+ return $ (\[a,b,c,d,e,f,g,h,i,j] -> GEA a b c d e f g h i j) l++presentationAttributes =+ do l <- mapM attr+ ["alignmentBaseline","baseline-shift","clip","clip-path", "clip-rule",+ "color", "color-interpolation", "color-interpolation-filters", "color-profile",+ "color-rendering", "cursor", "direction", "display", "dominant-baseline", "enable-background",+ "fill", "fill-opacity", "fill-rule", "filter", "flood-color", "flood-opacity", "font-family",+ "font-size", "font-size-adjust", "font-stretch", "font-style", "font-variant", "font-weight",+ "glyph-orientation-horizontal", "glyph-orientation-vertical", "image-rendering", "kerning",+ "letter-spacing", "lighting-color", "marker-end", "marker-mid", "marker-start", "mask",+ "opacity", "overflow", "pointer-events", "shape-rendering", "stop-color", "stop-opacity",+ "stroke", "stroke-dasharray", "stroke-dashoffset", "stroke-linecap", "stroke-linejoin",+ "stroke-miterlimit", "stroke-opacity", "stroke-width", "text-anchor", "text-decoration",+ "text-rendering", "unicode-bidi", "visibility", "word-spacing", "writing-mode"]+ return $+ (\[a,b,c0,c1,c2,c3,c4,c5,c6,c7,c8,d0,d1,d2,e,f0,f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12,+ g0,g1,i,k,l0,l1,m0,m1,m2,m3,o0,o1,p,s0,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,t0,t1,t2,u,v,w0,w1] ->+ PA a b c0 c1 c2 c3 c4 c5 c6 c7 c8 d0 d1 d2 e f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12+ g0 g1 i k l0 l1 m0 m1 m2 m3 o0 o1 p s0 s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 t0 t1 t2 u v w0 w1 ) l++filterPrimitiveAttributes =+ do l <- mapM attr+ [ "x","y","widh","height","result"]+ return $ (\[x,y,w,h,r] -> FPA x y w h r) l+++-- prefix :: Maybe T.Text -> T.Text -> Data.XML.Types.Name+-- prefix ns attribute = Name attribute ns Nothing++xlinkAttributes = -- xlinkNamespace is usually http://www.w3.org/1999/xlink+ do l <- mapM attr+ [ "{http://www.w3.org/1999/xlink}href", "{http://www.w3.org/1999/xlink}show", "{http://www.w3.org/1999/xlink}actuate",+ "{http://www.w3.org/1999/xlink}type", "{http://www.w3.org/1999/xlink}role", "{http://www.w3.org/1999/xlink}arcrole",+ "{http://www.w3.org/1999/xlink}title"]+ return $ (\[a,b,c,d,e,f,g] -> XLA a b c d e f g) l++xmlnsNameSpaces =+ do l <- mapM attr+ [ "{http://www.w3.org/2000/svg}xlink","{http://www.w3.org/2000/svg}dc", "{http://www.w3.org/2000/svg}cc",+ "{http://www.w3.org/2000/svg}rdf", "{http://www.w3.org/2000/svg}svg", "{http://www.w3.org/2000/svg}sodipodi",+ "{http://www.w3.org/2000/svg}inkscape" ]+ return $ (\[xlink,dc,cc,rdf,svg,sodipodi,inkscape] -> NSP xlink dc cc rdf svg sodipodi inkscape) l++xmlNameSpaces =+ do l <- mapM attr+ [ "{http://www.w3.org/XML/1998/namespace}space" ] -- the only attribute that seems to be used so far in the xml namespace is xml:space="preserve"+ return $ (\[space] -> space) l++--------------------------------------------------------------------------------------+-- Attributes for basic structure tags, see http://www.w3.org/TR/SVG/struct.html+--------------------------------------------------------------------------------------++-- | Attributes for \<svg\>, see <http://www.w3.org/TR/SVG/struct.html#SVGElement>+svgAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ xmlns <- xmlnsNameSpaces+ xml <- xmlNameSpaces+ l <- mapM attr+ ["class","style","externalResourcesRequired","x","y","width","height","viewBox","preserveAspectRatio",+ "zoomAndPan", "version", "baseProfile", "contentScriptType", "contentStyleType"]+ ignoreAttrs+ return $ (\[class_,style,ext,x,y,w,h,view,ar,zp,ver,baseprof,cScripT,cStyleT] -> + (cpa,ca,gea,pa,class_,style,ext,x,y,w,h,view,ar,zp,ver,baseprof,cScripT,cStyleT,xmlns,xml)) l++-- | Attributes for \<g\> and \<defs\>, see <http://www.w3.org/TR/SVG/struct.html#GElement>+gAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ class_ <- attr "class"+ style <- attr "style"+ ext <- attr "externalResourceRequired"+ tr <- attr "transform"+ ignoreAttrs+ return (cpa,ca,gea,pa,class_,style,ext,tr)++-- | Attributes for \<g\> and \<defs\>, see <http://www.w3.org/TR/SVG/struct.html#GElement>+sAttrs =+ do ca <- coreAttributes+ type_ <- attr "type"+ media <- attr "media"+ title <- attr "title"+ ignoreAttrs+ return (ca,type_,media,title)++-- | Attributes for \<desc\>, see <http://www.w3.org/TR/SVG/struct.html#DescriptionAndTitleElements>+descAttrs =+ do ca <- coreAttributes+ class_ <- attr "class"+ style <- attr "style"+ ignoreAttrs+ return (ca,class_,style)++-- | Attributes for \<symbol\>, see <http://www.w3.org/TR/SVG/struct.html#SymbolElement>+symbolAttrs =+ do ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","preserveAspectRatio","viewBox"]+ ignoreAttrs+ return $ (\[class_,style,ext,ar,viewbox] -> + (ca,gea,pa,class_,style,ext,ar,viewbox) ) l++-- | Attributes for \<use\>, see <http://www.w3.org/TR/SVG/struct.html#UseElement>+useAttrs =+ do ca <- coreAttributes+ cpa <- conditionalProcessingAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ xlink <- xlinkAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","x","y","width","height"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,x,y,w,h] -> + (ca,cpa,gea,pa,xlink,class_,style,ext,tr,x,y,w,h)) l++-- | Attributes for \<switch\>, see <http://www.w3.org/TR/SVG/struct.html#SwitchElement>+switchAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ class_ <- attr "class"+ style <- attr "style"+ ext <- attr "externalResourcesRequired"+ tr <- attr "transform"+ ignoreAttrs+ return (cpa,ca,gea,pa,class_,style,ext,tr)++--------------------------------------------------------------------------------------+-- Attributes for basic shape tags+--------------------------------------------------------------------------------------++-- | Attributes for \<rect\>, see <http://www.w3.org/TR/SVG11/shapes.html#RectElement>+rectAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","preserveAspectRatio","transform","x","y",+ "width","height","rx","ry"]+ ignoreAttrs+ return $ (\[class_,style,ext,ar,tr,x,y,w,h,rx,ry] -> + (cpa,ca,gea,pa,class_,style,ext,ar,tr,x,y,w,h,rx,ry) ) l++-- | Attributes for \<circle\>, see <http://www.w3.org/TR/SVG11/shapes.html#CircleElement>+circleAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","r","cx","cy"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,r,cx,cy] -> + (cpa,ca,gea,pa,class_,style,ext,tr,r,cx,cy) ) l++-- | Attributes for \<ellipse\>, see <http://www.w3.org/TR/SVG11/shapes.html#EllipseElement>+ellipseAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","rx","ry","cx","cy"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,rx,ry,cx,cy] -> + (cpa,ca,gea,pa,class_,style,ext,tr,rx,ry,cx,cy) ) l++-- | Attributes for \<line\>, see <http://www.w3.org/TR/SVG11/shapes.html#LineElement>+lineAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","x1","y1","x2","y2"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,x1,y1,x2,y2] -> + (cpa,ca,gea,pa,class_,style,ext,tr,x1,y1,x2,y2) ) l++-- | Attributes for \<polygon\>, see <http://www.w3.org/TR/SVG11/shapes.html#PolygonElement>+polygonAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","points"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,points] -> + (cpa,ca,gea,pa,class_,style,ext,tr,points) ) l++-- | Attributes for \<path\>, see <http://www.w3.org/TR/SVG11/paths.html#PathElement>+pathAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","d","pathLength"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,d,pathLength] -> + (cpa,ca,gea,pa,class_,style,ext,tr,d,pathLength) ) l++-------------------------------------------------------------------------------------+-- | Attributes for \<clipPath\>, see <http://www.w3.org/TR/SVG/masking.html#ClipPathElement>+clipPathAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","clipPathUnits"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,units] -> + (cpa,ca,pa,class_,style,ext,tr,units) ) l++-- | Attributes for \<pattern\>, see <http://www.w3.org/TR/SVG/pservers.html#PatternElement>+patternAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","viewBox","preserveAspectRatio","x","y",+ "width","height","patternUnits","patternContentUnits","patternTransform"]+ ignoreAttrs+ return $ (\[class_,style,ext,view,ar,x,y,w,h,pUnits,pCUnits,pTrans] -> + (cpa,ca,pa,class_,style,ext,view,ar,x,y,w,h,pUnits,pCUnits,pTrans) ) l++-- | Attributes for \<image\>, see <http://www.w3.org/TR/SVG/struct.html#ImageElement>+imageAttrs =+ do ca <- coreAttributes+ cpa <- conditionalProcessingAttributes+ gea <- graphicalEventAttributes+ xlink <- xlinkAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","preserveAspectRatio","transform",+ "x","y","width","height"]+ ignoreAttrs+ return $ (\[class_,style,ext,ar,tr,x,y,w,h] -> + (ca,cpa,gea,xlink,pa,class_,style,ext,ar,tr,x,y,w,h) ) l++-- | Attributes for \<font\>+fontAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","horiz-origin-x","horiz-origin-y","horiz-adv-x",+ "vert-origin-x","vert-origin-y","vert-adv-y"]+ ignoreAttrs+ return $ (\[class_,style,ext,horizOriginX,horizOriginY,horizAdvX,vertOriginX,vertOriginY,vertAdvY] -> + (ca,pa,class_,style,ext,horizOriginX,horizOriginY,horizAdvX,vertOriginX,vertOriginY,vertAdvY) ) l++-- | Attributes for \<font-face\>+fontFaceAttrs =+ do ca <- coreAttributes+ l <- mapM attr+ ["font-family","font-style","font-variant","font-weight","font-stretch","font-size","unicode-range","units-per-em","panose-1",+ "stemv","stemh","slope","cap-height","x-height","accent-height", "ascent", "descent", "widths", "bbox", "ideographic",+ "alphabetic","mathematical", "hanging", "v-ideographic", "v-alphabetic", "v-mathematical", "v-hanging", "underline-position",+ "underline-thickness", "strikethrough-position", "strikethrough-thickness", "overline-position", "overline-thickness"]+ ignoreAttrs+ return $ (\[fontFamily,fontStyle,fontVariant,fontWeight,fontStretch,fontSize,unicodeRange,unitsPerEm,panose1,+ stemv,stemh,slope,capHeight,xHeight,accentHeight,ascent,descent,widths,bbox,ideographic,alphabetic,mathematical,+ hanging,vIdeographic,vAlphabetic,vMathematical,vHanging,underlinePosition,underlineThickness,strikethroughPosition,+ strikethroughThickness,overlinePosition,overlineThickness] -> + (ca,fontFamily,fontStyle,fontVariant,fontWeight,fontStretch,fontSize,unicodeRange,unitsPerEm,panose1,+ stemv,stemh,slope,capHeight,xHeight,accentHeight,ascent,descent,widths,bbox,ideographic,alphabetic,mathematical,+ hanging,vIdeographic,vAlphabetic,vMathematical,vHanging,underlinePosition,underlineThickness,strikethroughPosition,+ strikethroughThickness,overlinePosition,overlineThickness) ) l++missingGlyphAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","d","horiz-adv-x","vert-origin-x","vert-origin-y","vert-adv-y"]+ ignoreAttrs+ return $ (\[class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY] -> + (ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY) ) l++glyphAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","d","horiz-adv-x","vert-origin-x","vert-origin-y","vert-adv-y","unicode","glyph-name",+ "orientation","arabic-form","lang"]+ ignoreAttrs+ return $ (\[class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY,unicode,glyphName,orientation,arabicForm,lang] -> + (ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY,unicode,glyphName,orientation,arabicForm,lang) ) l++kernAttrs =+ do ca <- coreAttributes+ l <- mapM attr+ ["u1","g1","u2","g2","k"]+ ignoreAttrs+ return $ (\[u1,g1,u2,g2,k] -> + (ca,u1,g1,u2,g2,k) ) l+++-- | Attributes for \<filter\>, see <http://www.w3.org/TR/SVG/filters.html#FilterElement>+filterAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ xlink <- xlinkAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","x","y","width","height","filterRes","filterUnits","primitiveUnits"]+ ignoreAttrs+ return $ (\[class_,style,ext,x,y,w,h,filterRes,filterUnits,primUnits] -> + (ca,pa,xlink,class_,style,ext,x,y,w,h,filterRes,filterUnits,primUnits) ) l++linearGradAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ xlink <- xlinkAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","x1","y1","x2","y2","gradientUnits","gradientTransform","spreadMethod"]+ ignoreAttrs+ return $ (\[class_,style,ext,x1,y1,x2,y2,gradientUnits,gradientTransform,spreadMethod] -> + (ca,pa,xlink,class_,style,ext,x1,y1,x2,y2,gradientUnits,gradientTransform,spreadMethod) ) l++radialGradAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ xlink <- xlinkAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","cx","cy","r","fx","fy","gradientUnits","gradientTransform","spreadMethod"]+ ignoreAttrs+ return $ (\[class_,style,ext,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod] -> + (ca,pa,xlink,class_,style,ext,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod) ) l++setAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ xlink <- xlinkAttributes+ ignoreAttrs+ return (ca,pa,xlink)++stopAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ xlink <- xlinkAttributes+ class_ <- attr "class"+ style <- attr "style"+ offset <- attr "offset"+ ignoreAttrs+ return $ (ca,pa,xlink,class_,style,offset)++-- | Attributes for \<text\>, see <http://www.w3.org/TR/SVG/text.html#TextElement>+textAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","transform","lengthAdjust",+ "x","y","dx","dy","rotate","textLength"]+ ignoreAttrs+ return $ (\[class_,style,ext,tr,la,x,y,dx,dy,rot,textlen] -> + (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) ) l++tspanAttrs =+ do cpa <- conditionalProcessingAttributes+ ca <- coreAttributes+ gea <- graphicalEventAttributes+ pa <- presentationAttributes+ p <- mapM attr+ [ "class","style","externalResourcesRequired", "x", "y", "dx", "dy", "rotate", "textLength", "lengthAdjust", + "{http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd}role" ]+ ignoreAttrs+ return $ ( \[class_, style, ext, x, y, dx, dy, rotate, textlen, lAdjust, role] -> + (cpa,ca,gea,pa,class_,style,ext,x,y,dx,dy,rotate,textlen,lAdjust,role) ) p++namedViewAttrs =+ do l <- mapM attr+ ["pagecolor","bordercolor","borderopacity","objecttolerance","gridtolerance",+ "guidetolerance", "id","showgrid"]+ inkscape <- mapM attr+ [ "{http://www.inkscape.org/namespaces/inkscape}pageopacity", "{http://www.inkscape.org/namespaces/inkscape}pageshadow",+ "{http://www.inkscape.org/namespaces/inkscape}window-width", "{http://www.inkscape.org/namespaces/inkscape}window-height",+ "{http://www.inkscape.org/namespaces/inkscape}zoom",+ "{http://www.inkscape.org/namespaces/inkscape}cx", "{http://www.inkscape.org/namespaces/inkscape}cy",+ "{http://www.inkscape.org/namespaces/inkscape}window-x", "{http://www.inkscape.org/namespaces/inkscape}window-y",+ "{http://www.inkscape.org/namespaces/inkscape}window-maximized", "{http://www.inkscape.org/namespaces/inkscape}current-layer"]+ ignoreAttrs+ return $ (\[pc,bc,bo,ot,gt,gut,id1,sg] [po,ps,ww,wh,zoom,cx,cy,wx,wy,wm,cl]->+ (pc,bc,bo,ot,gt,gut,po,ps,ww,wh,id1,sg,zoom,cx,cy,wx,wy,wm,cl) ) l inkscape++{- <inkscape:perspective+ sodipodi:type="inkscape:persp3d"+ inkscape:vp_x="0 : 212.5 : 1"+ inkscape:vp_y="0 : 1000 : 0"+ inkscape:vp_z="428.75 : 212.5 : 1"+ inkscape:persp3d-origin="214.375 : 141.66667 : 1"+ id="perspective5175" />+-}+perspectiveAttrs =+ do p <- mapM attr+ [ "{http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd}type",+ "{http://www.inkscape.org/namespaces/inkscape}vp_x",+ "{http://www.inkscape.org/namespaces/inkscape}vp_y",+ "{http://www.inkscape.org/namespaces/inkscape}vp_z",+ "{http://www.inkscape.org/namespaces/inkscape}persp3d-origin",+ "id"]+ ignoreAttrs+ return $ (\[typ,vp_x,vp_y,vp_z,persp3d_origin,id_] -> + (typ,vp_x,vp_y,vp_z,persp3d_origin,id_) ) p++-------------------------------------------------------------------------------------------------------------++feBlendAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","in2","mode"]+ ignoreAttrs+ return $ (\[class_,style,in1,in2,mode] -> (ca,pa,fpa,class_,style,in1,in2,mode) ) l++feColorMatrixAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","type","values"]+ ignoreAttrs+ return $ (\[class_,style,in1,type1,values] -> (ca,pa,fpa,class_,style,in1,type1,values) ) l++feComponentTransferAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in"]+ ignoreAttrs+ return $ (\[class_,style,in1] -> (ca,pa,fpa,class_,style,in1) ) l+feCompositeAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","in2","operator","k1","k2","k3","k4"]+ ignoreAttrs+ return $ (\[class_,style,in1,in2,operator,k1,k2,k3,k4] -> (ca,pa,fpa,class_,style,in1,in2,operator,k1,k2,k3,k4) ) l++feConvolveMatrixAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","order","kernelMatrix","divisor","bias","targetX","targetY","edgeMode","kernelUnitLength","preserveAlpha"]+ ignoreAttrs+ return $ (\[class_,style,order,km,d,bias,tx,ty,em,ku,pa] -> (ca,pa,fpa,class_,style,order,km,d,bias,tx,ty,em,ku,pa) ) l++feDiffuseLightingAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","surfaceScale","diffuseConstant","kernelUnitLength"]+ ignoreAttrs+ return $ (\[class_,style,in1,surfaceScale,diffuseConstant,kuLength] -> (ca,pa,fpa,class_,style,in1,surfaceScale,diffuseConstant,kuLength) ) l++feDisplacementMapAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","in2","scale","xChannelSelector","yChannelSelector"]+ ignoreAttrs+ return $ (\[class_,style,in1,in2,sc,xChan,yChan] -> (ca,pa,fpa,class_,style,in1,in2,sc,xChan,yChan) ) l++feFloodAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style"]+ ignoreAttrs+ return $ (\[class_,style] -> (ca,pa,fpa,class_,style) ) l++feGaussianBlurAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","stdDeviation"]+ ignoreAttrs+ return $ (\[class_,style,in1,stdDeviation] -> (ca,pa,fpa,class_,style,in1,stdDeviation) ) l++feImageAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ xlink <- xlinkAttributes+ l <- mapM attr+ ["class","style","externalResourcesRequired","preserveAspectRatio"]+ ignoreAttrs+ return $ (\[class_,style,ext,pa] -> (ca,pa,fpa,xlink,class_,style,ext,pa) ) l++feMergeAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style"]+ ignoreAttrs+ return $ (\[class_,style] -> (ca,pa,fpa,class_,style) ) l++feMorphologyAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","operator","radius"]+ ignoreAttrs + return $ (\[class_,style,in1,operator,radius] -> (ca,pa,fpa,class_,style,in1,operator,radius) ) l++feOffsetAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","dx","dy"]+ ignoreAttrs+ return $ (\[class_,style,in1,dx,dy] -> (ca,pa,fpa,class_,style,in1,dx,dy) ) l++feSpecularLightingAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","surfaceScale","specularConstant","specularExponent","kernelUnitLength"]+ ignoreAttrs+ return $ (\[class_,style,in1,surfaceScale,sc,se,ku] -> (ca,pa,fpa,class_,style,in1,surfaceScale,sc,se,ku) ) l++feTileAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in"]+ ignoreAttrs+ return $ (\[class_,style,in1] -> (ca,pa,fpa,class_,style,in1) ) l++feTurbulenceAttrs =+ do ca <- coreAttributes+ pa <- presentationAttributes+ fpa <- filterPrimitiveAttributes+ l <- mapM attr+ ["class","style","in","in2","mode"]+ ignoreAttrs+ return $ (\[class_,style,in1,in2,mode] -> (ca,pa,fpa,class_,style,in1,in2,mode) ) l+
+ src/Diagrams/SVG/Attributes.hs view
@@ -0,0 +1,1013 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, TypeFamilies, FlexibleContexts #-}++--------------------------------------------------------------------+-- |+-- Module : Diagrams.SVG.Attributes+-- Copyright : (c) 2015 Tillmann Vogt <tillk.vogt@googlemail.com>+-- License : BSD3+--+-- Maintainer: diagrams-discuss@googlegroups.com+-- Stability : stable+-- Portability: portable++module Diagrams.SVG.Attributes + (+ initialStyles+ -- * Classes of attributes+ , CoreAttributes(..)+ , ConditionalProcessingAttributes(..)+ , DocumentEventAttributes(..)+ , GraphicalEventAttributes(..)+ , XlinkAttributes(..)+ , FilterPrimitiveAttributes(..)+ , NameSpaces(..)+ -- * General Parsing Functions+ , separatedBy+ , parseOne+ , parseOne'+ , compose+ , parseDouble+ , parseToDouble+ , parsePoints+ , parseTempl+ , parseIRI+ -- * Transformations+ , applyTr+ , parseTr+ -- * Parsing the style attribute+ , applyStyleSVG+ , parseStyles+ , parseLengths+ , parseViewBox+ , parsePA+ , cssStylesFromMap+ , fragment+ , p+ , parseSpread+ -- * Parsing Colors+ -- * Parsing preserve aspect ratio+ , parsePreserveAR+ , PreserveAR(..)+ , AlignSVG(..)+ , Place(..)+ , MeetOrSlice(..)+ , SVGStyle(..)+ , PresentationAttributes(..)+ )+where++import Data.Attoparsec.Combinator+import Data.Attoparsec.Text+import qualified Data.Attoparsec.Text as AT+import Data.Char (isAlpha, isHexDigit, digitToInt)+import Data.Colour+import Data.Colour.Names (readColourName)+import Data.Colour.SRGB+import Data.Colour.RGBSpace.HSL (hsl)+import qualified Data.HashMap.Strict as H+import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes)+import qualified Data.Text as T+import Data.Text(Text(..), pack, unpack, empty, cons, snoc, append)+import Data.Typeable+import Data.Word (Word8)+import Diagrams.Prelude hiding (fillOpacity, strokeOpacity)+import Diagrams.SVG.Path+import Diagrams.SVG.Tree+import Text.CSS.Parse+import Diagrams.Core.Transform+import Data.Digits++---------------------------------------------------++data CoreAttributes =+ CA { id1 :: Maybe Text+ , xmlbase :: Maybe Text+ , xmllang :: Maybe Text+ , xmlspace :: Maybe Text+ }++data ConditionalProcessingAttributes =+ CPA { requiredFeatures :: Maybe Text+ , requiredExtensions :: Maybe Text+ , systemLanguage :: Maybe Text+ }++data DocumentEventAttributes =+ DEA { onunload :: Maybe Text+ , onabort :: Maybe Text+ , onerror :: Maybe Text+ , onresize :: Maybe Text+ , onscroll :: Maybe Text+ , onzoom :: Maybe Text+ }++data GraphicalEventAttributes =+ GEA { onfocusin :: Maybe Text+ , onfocusout :: Maybe Text+ , onactivate :: Maybe Text+ , onclick :: Maybe Text+ , onmousedown :: Maybe Text+ , onmouseup :: Maybe Text+ , onmouseover :: Maybe Text+ , onmousemove :: Maybe Text+ , onmouseout :: Maybe Text+ , onload :: Maybe Text+ }++data XlinkAttributes =+ XLA { xlinkHref :: Maybe Text+ , xlinkShow :: Maybe Text+ , xlinkActuate :: Maybe Text+ , xlinkType :: Maybe Text+ , xlinkRole :: Maybe Text+ , xlinkArcrole :: Maybe Text+ , xlinkTitle :: Maybe Text+ }++data FilterPrimitiveAttributes = + FPA { x :: Maybe Text+ , y :: Maybe Text+ , width :: Maybe Text+ , height :: Maybe Text+ , result :: Maybe Text+ }++data NameSpaces =+ NSP { xlink :: Maybe Text+ , dc :: Maybe Text+ , cc :: Maybe Text+ , rdf :: Maybe Text+ , svg :: Maybe Text+ , sodipodi :: Maybe Text+ , inkscape :: Maybe Text+ } deriving Show++--------------------------------------------------------------------------------+-- General parsing functions+--------------------------------------------------------------------------------++-- | Parsing content separated by something, e.g. ";" like in: "a;b;c;d;" or "a;b;c;d"+separatedBy parse sep = do ls <- many1 (choice [parseOne parse sep, parseOne' parse])+ return ls++parseOne parse sep = do AT.skipSpace+ s <- parse+ AT.string sep+ return s++parseOne' parse = do AT.skipSpace+ s <- parse+ return s++-- | See <http://www.haskell.org/haskellwiki/Compose>+compose :: [a -> a] -> a -> a+compose fs v = Prelude.foldl (flip (.)) id fs $ v++parseDouble :: RealFloat n => Text -> n+parseDouble l = either (const 0) (fromRational . toRational) (AT.parseOnly myDouble l)++parseToDouble :: RealFloat n => Maybe Text -> Maybe n+parseToDouble l | isJust l = either (const Nothing) (Just . fromRational . toRational) (AT.parseOnly myDouble (fromJust l))+ | otherwise = Nothing+pp = parseDouble . pack++myDouble = AT.choice [dotDouble, double]++dotDouble =+ do AT.skipSpace+ AT.char '.'+ frac <- AT.decimal+ let denominator = fromIntegral (10^(length $ digits 10 frac))+ return ((fromIntegral frac) / denominator)++parsePoints :: RealFloat n => Text -> [(n, n)]+parsePoints t = either (const []) id (AT.parseOnly (many' parsePoint) t)++parsePoint :: RealFloat n => Parser (n, n)+parsePoint =+ do AT.skipSpace+ a <- double+ AT.char ','+ b <- double+ return ( (fromRational . toRational) a, (fromRational . toRational) b)++parseUntil c = AT.manyTill AT.anyChar (AT.char c)++data Tup n = TS1 Text | TS2 Text Text | TS3 Text Text Text + | T1 n | T2 n n | T3 n n n + deriving Show++parse1 =+ do AT.skipSpace+ AT.char '('+ a <- AT.takeTill (== ')')+ AT.char ')'+ return (TS1 a)++parse2 =+ do AT.skipSpace+ AT.char '('+ a <- AT.takeTill (\c -> c == ',' || c == ' ')+ AT.choice [AT.char ',', AT.char ' ']+ AT.skipSpace+ b <- AT.takeTill (== ')')+ AT.char ')'+ return (TS2 a b)++parse3 =+ do AT.skipSpace+ AT.char '('+ a <- AT.takeTill (\c -> c == ',' || c == ' ')+ AT.choice [AT.char ',', AT.char ' ']+ b <- AT.takeTill (\c -> c == ',' || c == ' ')+ AT.choice [AT.char ',', AT.char ' ']+ c <- AT.takeTill (== ')')+ AT.char ')'+ return (TS3 a b c)++-----------------------------------------------------------------------------------------------------------------+-- Transformations, see <http://www.w3.org/TR/SVG11/coords.html#TransformAttribute>+-- +-- Example: transform="translate(-121.1511,-167.6958) matrix(4.675013,0,0,4.675013,-1353.75,-678.4329)"+-----------------------------------------------------------------------------------------------------------------++data Transform n = Tr (Tup n)+ | Matrix n n n n n n+ | Rotate (Tup n)+ | Scale (Tup n)+ | SkewX (Tup n)+ | SkewY (Tup n) deriving Show++parseTr :: RealFloat n => Maybe Text -> [Transform n]+parseTr = reverse .+ catMaybes .+ (either (const []) id) .+ ( AT.parseOnly (AT.many1 parseTransform)) .+ (fromMaybe empty)++parseTransform = AT.choice [matr, trans, scle, rot, skewX, skewY]++applyTr trs = compose (map getTransformations trs)++getTransformations (Tr (T1 x)) = translateX x+getTransformations (Tr (T2 x y)) = (translateX x) . (translateY y)++-- | See <http://www.w3.org/TR/SVG11/coords.html#TransformMatrixDefined>+getTransformations (Matrix a b c d e f)+ = (translateX x) . (translateY y) . (rotateBy angle) . (scaleX scX) . (scaleY scY)+ where (angle, scX, scY, x, y) = matrixDecompose (Matrix a b c d e f)+++-- matrix(0.70710678,-0.70710678,0.70710678,0.70710678,0,0)++getTransformations (Rotate (T1 angle)) = rotateBy angle+getTransformations (Rotate (T3 angle x y)) = id -- rotationAbout (p2 (x,y)) (angle)+getTransformations (Scale (T1 x)) = scaleX x+getTransformations (Scale (T2 x y)) = (scaleX x) . (scaleY y)+getTransformations (SkewX (T1 x)) = id+getTransformations (SkewY (T1 y)) = id++-- | See <http://math.stackexchange.com/questions/13150/extracting-rotation-scale-values-from-2d-transformation-matrix/13165#13165>+matrixDecompose (Matrix m11 m12 m21 m22 m31 m32) = (rotation, scX, scY, transX, transY)+ where+ rotation = (atan2 m12 m22) / (2*pi)+ scX | m11 >= 0 = sqrt (m11*m11 + m21*m21)+ | otherwise = - sqrt (m11*m11 + m21*m21)+ scY | m22 >= 0 = sqrt (m12*m12 + m22*m22)+ | otherwise = - sqrt (m12*m12 + m22*m22)+ (transX, transY) = (m31, m32)++matr =+ do AT.skipSpace+ AT.string "matrix"+ AT.skipSpace+ AT.char '('+ a <- parseUntil ','+ b <- parseUntil ','+ c <- parseUntil ','+ d <- parseUntil ','+ e <- parseUntil ','+ f <- parseUntil ')'+ return (Just $ Matrix (pp a) (pp b) (pp c) (pp d) (pp e) (pp f) )++evalTup (TS1 x) = T1 (parseDouble x)+evalTup (TS2 x y) = T2 (parseDouble x) (parseDouble y)+evalTup (TS3 x y z) = T3 (parseDouble x) (parseDouble y) (parseDouble z)++trans =+ do AT.skipSpace+ AT.string "translate" + tup <- AT.choice [parse2, parse1]+ return (Just $ Tr (evalTup tup))++scle =+ do AT.skipSpace+ AT.string "scale"+ tup <- AT.choice [parse2, parse1]+ return (Just $ Scale (evalTup tup))++rot =+ do AT.skipSpace+ AT.string "rotate"+ tup <- AT.choice [parse1, parse3]+ return (Just $ Rotate (evalTup tup))++skewX =+ do AT.skipSpace+ AT.string "skewX"+ angle <- parse1+ return (Just $ SkewX (evalTup angle))++skewY =+ do AT.skipSpace+ AT.string "skewY"+ angle <- parse1+ return (Just $ SkewY (evalTup angle))++------------------------------------------------------------------------------------------------+-- Parse the styles of various presentation attributes.+-- Example: <path fill="#FFFFFF" ...+-- Alternative way to writing everything into style="+------------------------------------------------------------------------------------------------++parsePA :: (RealFloat n, RealFloat a, Read a) => PresentationAttributes -> HashMaps b n -> [(SVGStyle n a)]+parsePA pa (nodes,css,grad) = l+ where l = catMaybes+ [(parseTempl (styleFillVal css grad)) (fill pa),+ (parseTempl styleFillRuleVal) (fillRuleSVG pa),+ (parseTempl styleFillOpacityVal) (fillOpacity pa),+ (parseTempl styleOpacityVal) (Diagrams.SVG.Tree.opacity pa),+ (parseTempl styleStrokeOpacityVal) (strokeOpacity pa),+ (parseTempl (styleStrokeVal css grad)) (strokeSVG pa),+ (parseTempl styleStrokeWidthVal) (strokeWidth pa),+ (parseTempl styleStrokeLineCapVal) (strokeLinecap pa),+ (parseTempl styleStrokeLineJoinVal) (strokeLinejoin pa),+ (parseTempl styleStrokeMiterLimitVal) (strokeMiterlimit pa),+ (parseTempl styleFontFamily) (fontFamily pa),+ (parseTempl styleFontSize) (fntSize pa),+ (parseTempl (styleClipPathVal nodes)) (clipPath pa),+ (parseTempl styleStrokeDashArrayVal) (strokeDasharray pa) ]++--------------------------------------------------------------------------------------------+-- Parse the style attribute, see <http://www.w3.org/TR/SVG/painting.html>+-- and <http://www.w3.org/TR/SVG/styling.html>+-- Example: style="fill:white;stroke:black;stroke-width:0.503546"+--------------------------------------------------------------------------------------------++data SVGStyle n a = Fill (AlphaColour a) | FillTex (Texture n) | FillOpacity Double | FillRule FR | Opacity Double+ | Stroke (AlphaColour a) | StrokeTex (Texture n) | StrokeWidth (LenPercent n) | StrokeLineCap LineCap+ | StrokeLineJoin LineJoin | StrokeMiterLimit n | StrokeDasharray [LenPercent n] | StrokeOpacity Double+ | FontFamily String | FontStyle FStyle | FontVariant FVariant | FontWeight FWeight | FontStretch FStretch+ | FontSize (LenPercent n)+ | ClipPath (Path V2 n)+ | EmptyStyle+++-- "font-style:normal;text-align:start;letter-spacing:0px;word-spacing:0px;writing-mode:lr-tb;text-anchor:start"+-- fontStyle letterSpacing wordSpacing writingMode textAnchor++data Unit = EM | EX | PX | IN | CM | MM | PT | PC deriving Show+data FR = Even_Odd | Nonzero | Inherit deriving Show+data LenPercent n = Len n | Percent n++instance Show (SVGStyle n a) where+ show (Fill c) = "Fill"+ show (FillTex t) = "Filltex"+ show (FillRule r) = "FillRule"+ show (FillOpacity d) = "FillOpacity"+ show (FontFamily f) = "FontFamily"+ show (FontStyle f) = "FontStyle"+ show (FontVariant f) = "FontVariant"+ show (FontWeight f) = "FontWeight"+ show (FontStretch f) = "FontStretch"+ show (FontSize f) = "FontSize"+ show (Diagrams.SVG.Attributes.Opacity d) = "Opacity"+ show (StrokeOpacity o) = "StrokeOpacity"+ show (Stroke s) = "Stroke"+ show (StrokeTex s) = "StrokeTex"+ show (StrokeWidth w) = "StrokeWidth"+ show (StrokeLineCap l) = "StrokeLineCap"+ show (StrokeLineJoin l) = "StrokeLineJoin"+ show (StrokeMiterLimit l) = "StrokeMiterLimit"+ show (StrokeDasharray l) = "StrokeDasharray"+ show (ClipPath path) = "ClipPath"+ show (EmptyStyle) = ""++instance Show (LenPercent n) where+ show (Len x) = "" -- show x+ show (Percent x) = "" -- show x++-- parseStyles :: (Read a, RealFloat a, RealFloat n) => Maybe Text -> HashMaps b n -> [(SVGStyle n a)]+parseStyles text hmaps = either (const []) id $+ AT.parseOnly (separatedBy (parseStyleAttr hmaps) ";") (fromMaybe empty text)++-- parseStyleAttr :: (Read a, RealFloat a, RealFloat n) => HashMaps b n -> Parser (SVGStyle n a)+parseStyleAttr (ns,css,grad) =+ AT.choice [styleFillRule, styleStrokeWidth, styleStrokeDashArray, styleFill css grad, styleStroke css grad, styleStopColor,+ styleStopOpacity, styleFillOpacity, styleStrokeOpacity, styleOpacity,+ styleFontFamily, styleFontStyle, styleFontVariant, styleFontWeight, styleFontStretch, styleFontSize,+ styleStrokeLineCap, styleStrokeLineJoin, styleStrokeMiterLimit, styleClipPath ns, skipOne]++skipOne = do str <- AT.manyTill AT.anyChar (AT.char ';') -- TODO end of input ?+ return EmptyStyle++-- | This function is called on every tag and returns a list of style-attributes to apply +-- (if there is a rule that matches)+-- TO DO: CSS2 + CSS3 selectors+-- cssStylesFromMap :: (Read a, RealFloat a, RealFloat n) =>+-- HashMaps b n -> Text -> Maybe Text -> Maybe Text -> [(SVGStyle n a)]+cssStylesFromMap (ns,css,grad) tagName id_ class_ = parseStyles ( Just ( T.concat ( map f attributes ) ) ) (ns,css,grad)+ where f (attr, val) = (attr `Data.Text.snoc` ':') `append` (val `Data.Text.snoc` ';')+ styleFromClass cl = [H.lookup ('.' `Data.Text.cons` cl) css] ++ [H.lookup (tagName `append` ('.' `Data.Text.cons` cl)) css]+ attributes = concat $ catMaybes+ ( [H.lookup "*" css] ++ -- apply this style to every element+ (if isJust id_ then [H.lookup ('#' `Data.Text.cons` (fromJust id_)) css] else []) +++ (concat (map styleFromClass (if isJust class_ then T.words $ fromJust class_ else [])))+ )++-- | a template that deals with the common parser errors+parseTempl :: Parser a -> Maybe Text -> Maybe a+parseTempl p = (either (const Nothing) Just) .+ (AT.parseOnly p).+ (fromMaybe empty)++-- | Given a minimum and maximum value of a viewbox (x or y-direction) and a maybe a Text value+-- Parse this Text value as a length (with a unit) or a percentage relative to the viewbox (minx,maxx)+-- If parsers fails return def+p :: RealFloat n => (n,n) -> n -> Maybe Text -> n+p (minx,maxx) def x = unL $ fromMaybe (Len def) $ parseTempl styleLength x+ where unL (Len x) = x+ unL (Percent x) = x/100 * (maxx-minx)++parseIRI = do AT.choice [ funcIRI, absoluteOrRelativeIRI ]++funcIRI =+ do AT.skipSpace+ AT.string "url("+ absrel <- parseUntil '#'+ frag <- parseUntil ')'+ return (T.pack absrel, T.pack frag)++absoluteOrRelativeIRI =+ do AT.skipSpace+ absrel <- parseUntil '#'+ frag <- takeText+ return (T.pack absrel, frag)++fragment x = fmap snd (parseTempl parseIRI x) -- look only for the text after "#"++-- | Inital styles, see: <http://www.w3.org/TR/SVG/painting.html#FillProperty>+initialStyles = lwL 1 . fc black . lineCap LineCapButt . lineJoin LineJoinMiter . lineMiterLimit 4 . lcA transparent+ . fontSize medium+ -- fillRule nonzero -- TODO+ -- fillOpcacity 1 -- TODO+ -- stroke-opacity 1 #+ -- stroke-dasharray none+ -- stroke-dashoffset 0 #+ -- display inline++applyStyleSVG stylesFromMap hmap = compose (map getStyles (stylesFromMap hmap))++getStyles (Fill c) = fcA c+getStyles (FillTex x) = fillTexture x+getStyles (FillRule Even_Odd) = fillRule EvenOdd+getStyles (FillRule Nonzero) = id+getStyles (FillRule Inherit) = id+getStyles (FillOpacity x) = Diagrams.Prelude.opacity x+getStyles (FontFamily str) = font str+getStyles (FontStyle s) = id+getStyles (FontVariant s) = id+getStyles (FontWeight s) = id+getStyles (FontStretch s) = id+getStyles (FontSize (Len len)) = fontSize (local len)+-- getStyles (FontSize (Percent len)) = fontSize (local len)+getStyles (Diagrams.SVG.Attributes.Opacity x) = Diagrams.Prelude.opacity x+getStyles (StrokeOpacity x) | x == 0 = lwL 0+ | otherwise = Diagrams.Prelude.opacity x -- we currently don't differentiate between fill opacity and stroke opacity+getStyles (Stroke x) = lcA x+getStyles (StrokeTex x) = lineTexture x+getStyles (StrokeWidth (Len x)) = lwL $ fromRational $ toRational x+getStyles (StrokeWidth (Percent x)) = lwG x+getStyles (StrokeLineCap x) = lineCap x+getStyles (StrokeLineJoin x) = lineJoin x+getStyles (StrokeMiterLimit x) = id+getStyles (StrokeDasharray array) = dashingL (map dash array) 0+ where dash (Len x) = x+ dash (Percent x) = x -- TODO implement percent length+getStyles (ClipPath path) = clipBy path+getStyles _ = id++-- | Example: style="fill:#ffb13b" style="fill:red"+styleFill css hmap =+ do AT.skipSpace+ AT.string "fill:"+ AT.skipSpace+ styleFillVal css hmap++styleFillVal css gradients = AT.choice [ styleFillColourVal, styleFillTexURL css gradients ]++styleFillColourVal =+ do c <- AT.choice [colorRRGGBB, colorRGB, colorString, colorRGBPercent, colorHSLPercent, colorNone, colorRGBWord]+ return (Fill c)++styleFillTexURL css gradients =+ do (absrel,frag) <- parseIRI+ let t = H.lookup frag gradients+ if isJust t then return (FillTex (getTexture (fromJust t)))+ else return EmptyStyle+ where getTexture (Gr refId ga vb stops f) = f css ga (fromMaybe (0,0,0,0) vb) stops++-- | Example: style="fill-rule:evenodd"+styleFillRule =+ do AT.skipSpace+ AT.string "fill-rule:"+ AT.skipSpace+ styleFillRuleVal++styleFillRuleVal =+ do AT.choice [ (do{ AT.string "evenodd"; return $ FillRule Even_Odd }),+ (do{ AT.string "nonzero"; return $ FillRule Nonzero }),+ (do{ AT.string "inherit"; return $ FillRule Inherit })+ ]++-- | Example: style="fill:#ffb13b" style="fill:red"+styleFillOpacity =+ do AT.skipSpace+ AT.string "fill-opacity:"+ AT.skipSpace+ styleFillOpacityVal++styleFillOpacityVal =+ do o <- myDouble+ return (FillOpacity $ fromRational $ toRational o)++-- | Example: style="fill:#ffb13b" style="fill:red"+styleOpacity =+ do AT.skipSpace+ AT.string "opacity:"+ AT.skipSpace+ styleOpacityVal++styleOpacityVal =+ do o <- myDouble+ return (Diagrams.SVG.Attributes.Opacity $ fromRational $ toRational o)+++-- | Example: style="stroke:black"+styleStroke css hmap =+ do AT.skipSpace+ AT.string "stroke:"+ AT.skipSpace+ styleStrokeVal css hmap++styleStrokeVal css gradients = AT.choice [ styleStrokeColourVal, styleStrokeTexURL css gradients ]++styleStrokeColourVal =+ do c <- AT.choice [colorRRGGBB, colorRGB, colorString, colorRGBPercent, colorHSLPercent, colorNone, colorRGBWord]+ return (Stroke c)++styleStrokeTexURL css gradients =+ do (absrel,frag) <- parseIRI+ let t = H.lookup frag gradients+ if isJust t then return (StrokeTex (getTexture (fromJust t)))+ else return EmptyStyle+ where getTexture (Gr refId ga vb stops f) = f css ga (fromMaybe (0,0,0,0) vb) stops++-- | Example: style="stroke-width:0.503546"+styleStrokeWidth =+ do AT.skipSpace+ AT.string "stroke-width:"+ styleStrokeWidthVal++styleStrokeWidthVal =+ do len <- styleLength+ return (StrokeWidth len)++-------------------------------------------------------------------------------------+-- font++styleFontFamily =+ do AT.skipSpace+ AT.string "font-family:"+ str <- AT.manyTill AT.anyChar theEnd+ return (FontFamily str)++theEnd = do AT.choice [AT.char ';', do { endOfInput; return ' '}]+++data FStyle = NormalStyle | Italic | Oblique | FSInherit++styleFontStyle =+ do AT.skipSpace+ AT.string "font-style:"+ AT.choice [ do { string "normal"; return (FontStyle NormalStyle)}+ , do { string "italic"; return (FontStyle Italic)}+ , do { string "oblique"; return (FontStyle Oblique)}+ , do { string "inherit"; return (FontStyle FSInherit)}+ ]+++data FVariant = NormalVariant | SmallCaps | VInherit++styleFontVariant =+ do AT.skipSpace+ AT.string "font-variant:"+ AT.choice [ do { string "normal"; return (FontVariant NormalVariant)}+ , do { string "small-caps"; return (FontVariant SmallCaps)}+ , do { string "inherit"; return (FontVariant VInherit)}+ ]+++data FWeight = NormalWeight | Bold | Bolder | Lighter + | N100 | N200 | N300 | N400 | N500 | N600 | N700 | N800 | N900+ | FWInherit++styleFontWeight =+ do AT.skipSpace+ AT.string "font-weight:"+ AT.choice [ do { string "normal"; return (FontWeight NormalWeight)}+ , do { string "bold"; return (FontWeight Bold)}+ , do { string "bolder"; return (FontWeight Bolder)}+ , do { string "lighter"; return (FontWeight Lighter)}+ , do { string "100"; return (FontWeight N100)}+ , do { string "200"; return (FontWeight N200)}+ , do { string "300"; return (FontWeight N300)}+ , do { string "400"; return (FontWeight N400)}+ , do { string "500"; return (FontWeight N500)}+ , do { string "600"; return (FontWeight N600)}+ , do { string "700"; return (FontWeight N700)}+ , do { string "800"; return (FontWeight N800)}+ , do { string "900"; return (FontWeight N900)}+ , do { string "inherit"; return (FontWeight FWInherit)}+ ]+++data FStretch = NormalStretch | Wider | Narrower | UltraCondensed | ExtraCondensed | Condensed+ | SemiCondensed | SemiExpanded | Expanded | ExtraExpanded | UltraExpanded | SInherit++styleFontStretch =+ do AT.skipSpace+ AT.string "font-stretch:"+ AT.choice [ do { string "normal"; return (FontStretch NormalStretch)}+ , do { string "wider"; return (FontStretch Wider)}+ , do { string "narrower"; return (FontStretch Narrower)}+ , do { string "ultra-condensed"; return (FontStretch UltraCondensed)}+ , do { string "extra-condensed"; return (FontStretch ExtraCondensed)}+ , do { string "condensed"; return (FontStretch Condensed)}+ , do { string "semi-condensed"; return (FontStretch SemiCondensed)}+ , do { string "semi-expanded"; return (FontStretch SemiExpanded)}+ , do { string "expanded"; return (FontStretch Expanded)}+ , do { string "extra-expanded"; return (FontStretch ExtraExpanded)}+ , do { string "ultra-expanded"; return (FontStretch UltraExpanded)}+ , do { string "inherit"; return (FontStretch SInherit)}+ ]++styleFontSize =+ do AT.skipSpace+ AT.string "font-size:"+ len <- styleLength+ return (FontSize len)++------------------------------------------------------------------------------------------------------------++-- | See <http://www.w3.org/TR/SVG/types.html#Length>+styleLength =+ do AT.skipSpace+ d <- myDouble+ AT.skipSpace+ AT.choice [ styleLengthWithUnit (fromRational $ toRational d),+ lengthPercent (fromRational $ toRational d), return (Len (fromRational $ toRational d)) ]++styleLengthWithUnit d =+ do u <- styleUnit+ return (Len (d * (unitFactor u)))++lengthPercent d =+ do AT.string "%"+ return (Percent d)++styleUnit = do AT.choice [styleEM,styleEX,stylePX,styleIN,styleCM,styleMM,stylePT,stylePC]++styleEM = do { AT.choice [AT.string "em", AT.string "EM"]; return EM }+styleEX = do { AT.choice [AT.string "ex", AT.string "EX"]; return EX }+stylePX = do { AT.choice [AT.string "px", AT.string "PX"]; return PX }+styleIN = do { AT.choice [AT.string "in", AT.string "IN"]; return IN }+styleCM = do { AT.choice [AT.string "cm", AT.string "CM"]; return CM }+styleMM = do { AT.choice [AT.string "mm", AT.string "MM"]; return MM }+stylePT = do { AT.choice [AT.string "pt", AT.string "PT"]; return PT }+stylePC = do { AT.choice [AT.string "pc", AT.string "PC"]; return PC }++unitFactor EM = 1+unitFactor EX = 1+unitFactor PX = 1+unitFactor IN = 90+unitFactor CM = 35.43307+unitFactor MM = 3.543307+unitFactor PT = 1.25+unitFactor PC = 15++-- | Example: "stroke-linecap:butt"+styleStrokeLineCap =+ do AT.skipSpace+ AT.string "stroke-linecap:"+ AT.skipSpace+ styleStrokeLineCapVal++styleStrokeLineCapVal =+ do lc <- AT.choice [butt,round0,square0]+ return (StrokeLineCap lc)++butt = do { AT.string "butt"; return LineCapButt }+round0 = do { AT.string "round"; return LineCapRound }+square0 = do { AT.string "square"; return LineCapSquare }++-- | Example: "stroke-linejoin:miter;"+styleStrokeLineJoin =+ do AT.skipSpace+ AT.string "stroke-linejoin:"+ AT.skipSpace+ styleStrokeLineJoinVal++styleStrokeLineJoinVal =+ do lj <- AT.choice [miter,round1,bevel]+ return (StrokeLineJoin lj)++miter = do { AT.string "miter"; return LineJoinMiter }+round1 = do { AT.string "round"; return LineJoinRound }+bevel = do { AT.string "bevel"; return LineJoinBevel }++styleClipPath hmap =+ do AT.skipSpace+ AT.string "clip-path:"+ AT.skipSpace+ styleClipPathVal hmap++styleClipPathVal hmap =+ do (absrel,frag) <- parseIRI+ let t = H.lookup frag hmap+ if isJust t then return (ClipPath $ evalPath hmap Nothing (fromJust t))+ else return EmptyStyle++-- | Evaluate the tree to a path. Is only needed for clipPaths+evalPath :: RealFloat n => H.HashMap Text (Tag b n) -> Maybe (ViewBox n) -> (Tag b n) -> Path V2 n+evalPath hmap (Just viewBox) (Leaf id1 path diagram) = path viewBox+evalPath hmap Nothing (Leaf id1 path diagram) = path (0,0,1,1) -- shouldn't happen, there should always be a viewbox+evalPath hmap _ (SubTree _ id1 _ (Just viewBox) ar f children) = mconcat (map (evalPath hmap (Just viewBox)) children)+evalPath hmap (Just viewBox) (SubTree _ id1 _ Nothing ar f children) = mconcat (map (evalPath hmap (Just viewBox)) children)+-- evalPath hmap (Reference selfId id1 wh f) = evalPath hmap (lookUp hmap (fragment id1)) -- TODO implement (not that common)+evalPath hmap _ _ = mempty++-- | Lookup a diagram and return an empty diagram in case the SVG-file has a wrong reference+lookUp hmap i | isJust l = fromJust l+ | otherwise = Leaf Nothing mempty mempty -- an empty diagram if we can't find the id+ where l = H.lookup i hmap++-- | Example: "stroke-miterlimit:miter;"+styleStrokeMiterLimit =+ do AT.skipSpace+ AT.string "stroke-miterlimit:"+ AT.skipSpace+ styleStrokeMiterLimitVal++styleStrokeMiterLimitVal =+ do l <- myDouble+ return $ StrokeMiterLimit $ (fromRational . toRational) l++styleStrokeDashArray =+ do AT.skipSpace+ AT.string "stroke-dasharray:"+ styleStrokeDashArrayVal++styleStrokeDashArrayVal =+ do len <- parseLengths+ return (StrokeDasharray len)++parseLengths = separatedBy styleLength ","++styleStrokeOpacity =+ do AT.skipSpace+ AT.string "stroke-opacity:"+ AT.skipSpace+ styleStrokeOpacityVal++styleStrokeOpacityVal =+ do l <- myDouble+ return $ StrokeOpacity $ (fromRational . toRational) l++styleStopColor =+ do AT.skipSpace+ AT.string "stop-color:"+ AT.skipSpace+ styleFillColourVal++styleStopOpacity =+ do AT.skipSpace+ AT.string "stop-opacity:"+ AT.skipSpace+ styleFillOpacityVal++-- TODO: Visibility, marker+-----------------------------------------------------------------------+-- Colors, see <http://www.w3.org/TR/SVG/color.html> and +-- <http://www.w3.org/TR/SVG/painting.html#SpecifyingPaint>+-----------------------------------------------------------------------++colorString =+ do a <- Data.Attoparsec.Text.takeWhile isAlpha+ c <- readColourName (unpack a)+ return (opaque c)++colorRGB =+ do AT.char '#'+ h0 <- satisfy isHexDigit+ h1 <- satisfy isHexDigit+ h2 <- satisfy isHexDigit+ return $ opaque ( sRGB24 (fromIntegral ((digitToInt h0) * 16))+ (fromIntegral ((digitToInt h1) * 16))+ (fromIntegral ((digitToInt h2) * 16)) )++colorRRGGBB =+ do AT.char '#'+ h0 <- satisfy isHexDigit+ h1 <- satisfy isHexDigit+ h2 <- satisfy isHexDigit+ h3 <- satisfy isHexDigit+ h4 <- satisfy isHexDigit+ h5 <- satisfy isHexDigit+ return $ opaque ( sRGB24 (fromIntegral ((digitToInt h0) * 16 + (digitToInt h1)) )+ (fromIntegral ((digitToInt h2) * 16 + (digitToInt h3)) )+ (fromIntegral ((digitToInt h4) * 16 + (digitToInt h5)) ) )++colorRGBWord =+ do AT.string "rgb("+ AT.skipSpace+ r <- decimal+ AT.skipSpace+ AT.char ','+ AT.skipSpace+ g <- decimal+ AT.skipSpace+ AT.char ','+ AT.skipSpace+ b <- decimal+ AT.skipSpace+ AT.char ')'+ return $ opaque (sRGB ((fromIntegral r)/255) ((fromIntegral g)/255) ((fromIntegral b)/255))++colorRGBPercent =+ do AT.string "rgb("+ AT.skipSpace+ r <- decimal+ AT.char '%'+ AT.skipSpace+ AT.char ','+ AT.skipSpace+ g <- decimal+ AT.char '%'+ AT.skipSpace+ AT.char ','+ AT.skipSpace+ b <- decimal+ AT.char '%'+ AT.skipSpace+ AT.char ')'+ return $ opaque (sRGB ((fromIntegral r)/100) ((fromIntegral g)/100) ((fromIntegral b)/100))++colorHSLPercent =+ do AT.string "hsl("+ AT.skipSpace+ h <- decimal+ AT.char '%'+ AT.skipSpace+ AT.char ','+ AT.skipSpace+ s <- decimal+ AT.char '%'+ AT.skipSpace+ AT.char ','+ AT.skipSpace+ l <- decimal+ AT.char '%'+ AT.skipSpace+ AT.char ')'+ let c = hsl (fromIntegral h) (fromIntegral s) (fromIntegral l)+ return $ opaque (sRGB (channelRed c) (channelGreen c) (channelBlue c))++colorNone =+ do AT.string "none"+ return transparent++-------------------------------------------------------------------------------------+-- | Example: spreadMethod="pad"+parseSpread :: Maybe Text -> SpreadMethod+parseSpread spr | isJust parsedSpread = fromJust parsedSpread+ | otherwise = GradPad -- most of the time its "pad"+ where parsedSpread = parseTempl gradSpread spr++gradSpread = AT.choice [gradPad, gradReflect, gradRepeat ]++gradPad = do AT.string "pad"+ return GradPad++gradReflect = do AT.string "reflect"+ return GradReflect++gradRepeat = do AT.string "repeat"+ return GradRepeat++-------------------------------------------------------------------------------------+-- | Example: viewBox="0 0 100 30"+-- Viewboxes establish a new viewport. Percentages (e.g. x="50%") only make sense with a viewport.+parseViewBox :: RealFloat n => Maybe Text -> Maybe Text -> Maybe Text -> Maybe (ViewBox n)+parseViewBox vb w h | isJust parsedVB = parsedVB -- This is how it should always be, + -- but sometimes an <svg>-tag has no viewbox attribute+ | pw == 0 || ph == 0 = Nothing -- TODO: What does a browser do here?+ | otherwise = Just (0,0,pw, ph) -- If there is no viewbox the image size is the viewbox + -- TODO: What does a browser do here?+ -- The only other option I see is finding the min and max values of+ -- shapes in user coordinate system, ignoring percentages+ -- But one pass to just find out the viewbox?+ where parsedVB = parseTempl viewBox vb++ -- Assuming percentages are not used in width/height of the top <svg>-tag+ -- and there are no sub-<svg>-tags that use percentage-width/height to refer to their calling viewbox+ -- Using width and height is a hack anyway+ pw | isJust w = parseDouble $ fromJust w+ | otherwise = 0+ ph | isJust h = parseDouble $ fromJust h+ | otherwise = 0++viewBox =+ do AT.skipSpace+ minx <- myDouble+ AT.skipSpace+ miny <- myDouble+ AT.skipSpace+ width <- myDouble+ AT.skipSpace+ height <- myDouble+ AT.skipSpace+ return ((fromRational . toRational) minx,+ (fromRational . toRational) miny,+ (fromRational . toRational) width,+ (fromRational . toRational) height)++-------------------------------------------------------------------------------------+-- Parse preserve aspect ratio+-- e.g. preserveAspectRatio="xMaxYMax meet"+-------------------------------------------------------------------------------------++parsePreserveAR x = parseTempl preserveAR x++preserveAR =+ do AT.skipSpace+ align <- AT.choice [alignXMinYMin,alignXMidYMin,alignXMaxYMin,alignXMinYMid,alignXMidYMid,+ alignXMaxYMid,alignXMinYMax,alignXMidYMax,alignXMaxYMax]+ AT.skipSpace+ meetOrSlice <- AT.choice [meet, slice]+ return (PAR align meetOrSlice)++meet =+ do AT.string "meet"+ return Meet++slice =+ do AT.string "slice"+ return Slice++alignXMinYMin =+ do AT.string "xMinYMin"+ return (AlignXY 0 0)++alignXMidYMin =+ do AT.string "xMidYMin"+ return (AlignXY 0.5 0)++alignXMaxYMin =+ do AT.string "xMaxYMin"+ return (AlignXY 1 0)++alignXMinYMid =+ do AT.string "xMinYMid"+ return (AlignXY 0 0.5)++alignXMidYMid =+ do AT.string "xMidYMid"+ return (AlignXY 0.5 0.5)++alignXMaxYMid =+ do AT.string "xMaxYMid"+ return (AlignXY 1 0.5)++alignXMinYMax =+ do AT.string "xMinYMax"+ return (AlignXY 0 1)++alignXMidYMax =+ do AT.string "xMidYMax"+ return (AlignXY 0.5 1)++alignXMaxYMax =+ do AT.string "xMaxYMax"+ return (AlignXY 1 1)+
+ src/Diagrams/SVG/Fonts/CharReference.hs view
@@ -0,0 +1,57 @@+module Diagrams.SVG.Fonts.CharReference (charsFromFullName, characterStrings) where +import Control.Applicative ((<|>), many) +import Data.Attoparsec.Text +import qualified Data.Text as T +import Data.List (sortBy) + +charRef :: Parser Int +charRef + = do + _ <- try (string (T.pack "&#x")) + d <- hexadecimal + _ <- char ';' + return d + <|> do + _ <- try (string (T.pack "&#")) + d <- decimal + _ <- char ';' + return d + <|> do + c <- anyChar + return (fromEnum c) + <?> "character reference" + +charRefs :: Parser [Int] +charRefs = do l <- many1 charRef + return l + +fromCharRefs :: T.Text -> [Int] +fromCharRefs str + = case (parseOnly charRefs str) of + Right x -> x + Left _ -> [] + +-- | Parsing of xml character references. +-- +-- I.e. \"\&\#x2e\;\&\#x2e\;\&\#x2e\;\" is converted into a list of three Chars. +-- +-- \"ffb\" is also parsed and converted into three Chars (not changing it). +charsFromFullName :: String -> String +charsFromFullName str = map toEnum ( fromCharRefs (T.pack str) ) + + +-- | A string represents a glyph, i.e. the ligature \"ffi\" is a string that represents the ligature glyph ffi +characterStrings :: String -> [String] -> [T.Text] +characterStrings str ligs | null ligs = map ((T.pack).(\x->[x])) str + | otherwise = case parseOnly myParser (T.pack str) + of Right x -> x + Left _ -> [] + where myParser = many (try ligatures <|> charToText) + ligatures = buildChain $ sortBy -- sort so that the longest ligatures come first, i.e. "ffi", "ff", .. + (\x y -> compare (length y) (length x)) $ ligs + buildChain [] = string (T.pack "") -- will never be called, just to get rid of the warning message + buildChain [x] = parseLigature x -- try to parse with the first parsers in the chain first + buildChain (x:xs) = try (parseLigature x) <|> buildChain xs + parseLigature x = string (T.pack x) + charToText = do c <- anyChar -- or accept a single char + return (T.singleton c)
+ src/Diagrams/SVG/Fonts/ReadFont.hs view
@@ -0,0 +1,190 @@+module Diagrams.SVG.Fonts.ReadFont+ (+ FontData(..)+ , FontFace(..)+ , Kern(..)+ , KernDir(..)+ , FontContent(..)++ , parseBBox+-- , bbox_dy+-- , bbox_lx, bbox_ly++-- , underlinePosition+-- , underlineThickness++ , kernMap+ , horizontalAdvance+-- , kernAdvance++ , OutlineMap+ , PreparedFont+ ) where++import Data.Char (isSpace)+import Data.List (intersect, sortBy)+import Data.List.Split (splitOn, splitWhen)+import qualified Data.HashMap.Strict as H+import Data.Maybe (catMaybes, fromJust, fromMaybe, + isJust, isNothing, maybeToList)+import qualified Data.Text as T+import Data.Text (Text(..), pack, unpack, empty, words)+import Data.Text.Read (double)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Diagrams.Path+import Diagrams.Prelude hiding (font)++import Diagrams.SVG.Fonts.CharReference (charsFromFullName)+import Diagrams.SVG.Path+import Diagrams.SVG.Tree++kernMap :: [Kern n] -> KernMaps n+kernMap kernlist = KernMaps [] H.empty H.empty H.empty H.empty V.empty -- (transformChars (map kernU1)+ where+ transformChars chars = H.fromList $ map ch $ multiSet $ map (\(x,y) -> (x,[y])) $ sort fst $ + concat $ addIndex chars -- e.g. [["aa","b"],["c","d"]] to [("aa",0),("b",0),("c",1), ("d",1)]+ ch (x,y) | null x = ("",y)+ | otherwise = (x,y)++ addIndex qs = zipWith (\x y -> (map (\z -> (z,x)) y)) [0..] qs+ sort f xs = sortBy (\x y -> compare (f x) (f y) ) xs++ multiSet [] = []+ multiSet (a:[]) = [a] -- example: [("n1",[0]),("n1",[1]),("n2",[1])] to [("n1",[0,1]),("n2",[1])]+ multiSet (a:b:bs) | fst a == fst b = multiSet ( (fst a, (snd a) ++ (snd b)) : bs)+ | otherwise = a : (multiSet (b:bs))++ fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f))+++parseBBox :: (Read n, RealFloat n) => Maybe Text -> [n]+parseBBox bbox = maybe [] ((map convertToN) . T.words) bbox+ where convertToN = fromRational . toRational . (either (const 0) fst) . double++-- glyphs = map glyphsWithDefaults glyphElements++ -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with "horiz-adv-x=" in <font>+-- glyphsWithDefaults g = (charsFromFullName $ fromMaybe gname (findAttr (unqual "unicode") g), -- there is always a name or unicode+-- (+-- gname,+-- fromMaybe fontHadv (fmap read (findAttr (unqual "horiz-adv-x") g)),+-- fromMaybe "" (findAttr (unqual "d") g)+-- )+-- )+-- where gname = fromMaybe "" (findAttr (unqual "glyph-name") g)++-- | Horizontal advance of a character consisting of its width and spacing, extracted out of the font data+horizontalAdvance :: RealFloat n => Text -> FontData b n -> n+horizontalAdvance ch fontD+ | isJust char = (\(a,b,c) -> b) (fromJust char)+ | otherwise = fontDataHorizontalAdvance fontD+ where char = (H.lookup ch (fontDataGlyphs fontD))++-- | See <http://www.w3.org/TR/SVG/fonts.html#KernElements>+--+-- Some explanation how kerning is computed:+--+-- In Linlibertine.svg, there are two groups of chars: e.g.+-- \<hkern g1=\"f,longs,uni1E1F,f_f\" g2=\"parenright,bracketright,braceright\" k=\"-37\" />+-- This line means: If there is an f followed by parentright, reduce the horizontal advance by -37 (add 37).+-- Therefore to quickly check if two characters need kerning assign an index to the second group (g2 or u2)+-- and assign to every unicode in the first group (g1 or u1) this index, then sort these tuples after their+-- name (for binary search). Because the same unicode char can appear in several g1s, reduce this 'multiset',+-- ie all the (\"name1\",0) (\"name1\",1) to (\"name1\",[0,1]).+-- Now the g2s are converted in the same way as the g1s.+-- Whenever two consecutive chars are being printed try to find an+-- intersection of the list assigned to the first char and second char++-- | Change the horizontal advance of two consective chars (kerning)+{-+kernAdvance :: RealFloat n => String -> String -> KernMaps n -> Bool -> n+kernAdvance ch0 ch1 kern u | u && not (null s0) = (kernK kern) V.! (head s0)+ | not u && not (null s1) = (kernK kern) V.! (head s1)+ | otherwise = 0+ where s0 = intersect (s kernU1S ch0) (s kernU2S ch1)+ s1 = intersect (s kernG1S ch0) (s kernG2S ch1)+ s sel ch = concat (maybeToList (Map.lookup ch (sel kern)))+-}+-- > import Graphics.SVGFonts.ReadFont+-- > textWH0 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "SPACES" lin INSIDE_WH KERN False 8 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL+-- > textWH1 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "are sometimes better." lin INSIDE_WH KERN False 8 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL+-- > textWH2 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "But too many chars are not good." lin INSIDE_WH KERN False 8 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL+-- > textWH = textWH0 # alignBL === strutY 0.3 === textWH1 === strutY 0.3 === textWH2 # alignBL+-- > textW0 = (rect 3 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 3 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL+-- > textW1 = (rect 10 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 10 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL+-- > textW = textW0 # alignBL ||| strutX 1 ||| textW1 # alignBL+-- > textH0 = (rect 10 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 10 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL+-- > textH1 = (rect 3 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 3 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL+-- > textH = textH0 # alignBL === strutY 0.5 === textH1 # alignBL++-- > import Graphics.SVGFonts.ReadFont+-- > textHADV = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H HADV False 10 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd++-- > import Graphics.SVGFonts.ReadFont+-- > textKern = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H KERN False 10 1 )+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd++{-+-- | Difference between highest and lowest y-value of bounding box+bbox_dy :: RealFloat n => FontData n -> n+bbox_dy fontData = (bbox!!3) - (bbox!!1)+ where bbox = fontDataBoundingBox fontData -- bbox = [lowest x, lowest y, highest x, highest y]++-- | Lowest x-value of bounding box+bbox_lx :: RealFloat n => FontData n -> n+bbox_lx fontData = (fontDataBoundingBox fontData) !! 0++-- | Lowest y-value of bounding box+bbox_ly :: RealFloat n => FontData n -> n+bbox_ly fontData = (fontDataBoundingBox fontData) !! 1++-- | Position of the underline bar+underlinePosition :: RealFloat n => FontData n -> n+underlinePosition fontData = fontDataUnderlinePos fontData++-- | Thickness of the underline bar+underlineThickness :: RealFloat n => FontData n -> n+underlineThickness fontData = fontDataUnderlineThickness fontData+-}+-- | A map of unicode characters to outline paths.+type OutlineMap n = H.HashMap Text (Path V2 n)++-- | A map of unicode characters to parsing errors.+type ErrorMap = H.HashMap Text Text++-- | A font including its outline map.+type PreparedFont b n = (FontData b n, OutlineMap n)++-- | Compute a font's outline map, collecting errors in a second map.+outlineMap :: (Read n, Show n, RealFloat n) =>+ FontData b n -> (OutlineMap n, ErrorMap)+outlineMap fontData =+ ( H.fromList [(ch, outl) | (ch, Right outl) <- allOutlines]+ , H.fromList [(ch, err) | (ch, Left err) <- allOutlines]+ )+ where+ allUnicodes = H.keys (fontDataGlyphs fontData)+ outlines ch = return $ mconcat $ commandsToPaths (commandsFromChar ch (fontDataGlyphs fontData))+ allOutlines = [(ch, outlines ch) | ch <- allUnicodes]++-- | Prepare font for rendering, by determining its outline map.+prepareFont :: (Read n, Show n, RealFloat n) =>+ FontData b n -> (PreparedFont b n, ErrorMap)+prepareFont fontData = ((fontData, outlines), errs)+ where+ (outlines, errs) = outlineMap fontData++commandsFromChar :: RealFloat n => Text -> SvgGlyphs n -> [PathCommand n]+commandsFromChar ch glyph = case H.lookup ch glyph of+-- Just e -> commands (Just $ pack $ (\(a,b,c) -> c) e)+ Nothing -> []+
+ src/Diagrams/SVG/Path.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- Parsing the SVG path command, see <http://www.w3.org/TR/SVG/paths.html#PathData>+-------------------------------------------------------------------------------------++module Diagrams.SVG.Path+ (+ -- * Converting Path Commands+ commandsToPaths+ , splittedCommands+ , outline+ , nextSegment+ , svgArc+ -- * Parsing (Generating Path Commands)+ , PathCommand(..)+ , parsePathCommand+ , commands+ )+where++import Data.Attoparsec.Combinator+import Data.Attoparsec.Text+import qualified Data.Attoparsec.Text as AT+import Data.Char (isAlpha, isHexDigit, digitToInt)+import Data.Colour.Names (readColourName)+import Data.Colour.SRGB+import qualified Data.List.Split as S+import Data.List (foldl')+import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes)+import qualified Data.Text as T+import Data.Text(Text(..), pack, unpack, empty)+import Diagrams.Attributes+import Diagrams.Path+import Diagrams.Segment+import Diagrams.TwoD.Types+import Diagrams.Prelude++data AbsRel = Abs | Rel deriving Show+data PathCommand n =+ M AbsRel !(n,n) | -- ^AbsRel (x,y): Establish a new current point (with absolute coords)+ Z | -- ^Close current subpath by drawing a straight line from current point to current subpath's initial point+ L AbsRel !(n,n) | -- ^AbsRel (X,Y): A line from the current point to Tup which becomes the new current point+ H AbsRel !n | -- ^AbsRel x: A horizontal line from the current point (cpx, cpy) to (x, cpy)+ V AbsRel !n | -- ^AbsRel y: A vertical line from the current point (cpx, cpy) to (cpx, y)+ C AbsRel !(n,n,n,n,n,n) | -- ^AbsRel (X1,Y1,X2,Y2,X,Y): Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the+ -- ^control point at the beginning of the curve and (x2,y2) as the control point at the end of the curve.+ S AbsRel !(n,n,n,n) | -- ^AbsRel (X2,Y2,X,Y): Draws a cubic Bézier curve from the current point to (x,y). The first control point is+-- assumed to be the reflection of the second control point on the previous command relative to the current point.+-- (If there is no previous command or if the previous command was not an C, c, S or s, assume the first control+-- point is coincident with the current point.) (x2,y2) is the second control point (i.e., the control point at+-- the end of the curve).+ Q AbsRel !(n,n,n,n) | -- ^AbsRel (X1,Y1,X,Y): A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point.+-- Nearly the same as cubic, but with one point less+ T AbsRel !(n,n) | -- ^AbsRel (X,Y): T_Abs = Shorthand/smooth quadratic Bezier curveto+ A AbsRel !(n,n,n,n,n,n,n) -- ^AbsRel (rx,ry,xAxisRot,fl0,fl1,x,y): Elliptic arc+ deriving Show+++-- | The parser to parse the lines and curves that make an outline+parsePathCommand = do { AT.skipSpace;+ AT.choice [parse_m, parse_M, parse_l, parse_L, parse_h, parse_H,+ parse_v, parse_V, parse_c, parse_C, parse_S, parse_s,+ parse_q, parse_Q, parse_t, parse_T, parse_a, parse_A, parse_z]+ }++-- Although it makes no sense, some programs produce several M in sucession+parse_m = do { AT.string "m"; t <- many' tuple2; return (Just $ (M Rel $ head t): (map (L Rel) (tail t)) ) } -- that's why we need many'+parse_M = do { AT.string "M"; t <- many' tuple2; return (Just $ map (M Abs) t) }+parse_z = do { AT.choice [AT.string "z", AT.string "Z"]; return (Just [Z]) }+parse_l = do { AT.string "l"; t <- many' tuple2; return (Just $ map (L Rel) t) }+parse_L = do { AT.string "L"; t <- many' tuple2; return (Just $ map (L Abs) t) }+parse_h = do { AT.string "h"; t <- many' spaceDouble; return (Just $ map (H Rel) t) }+parse_H = do { AT.string "H"; t <- many' spaceDouble; return (Just $ map (H Abs) t) }+parse_v = do { AT.string "v"; t <- many' spaceDouble; return (Just $ map (V Rel) t) }+parse_V = do { AT.string "V"; t <- many' spaceDouble; return (Just $ map (V Abs) t) }+parse_c = do { AT.string "c"; t <- many' tuple6; return (Just $ map (C Rel) t) }+parse_C = do { AT.string "C"; t <- many' tuple6; return (Just $ map (C Abs) t) }+parse_s = do { AT.string "s"; t <- many' tuple4; return (Just $ map (S Rel) t) }+parse_S = do { AT.string "S"; t <- many' tuple4; return (Just $ map (S Abs) t) }+parse_q = do { AT.string "q"; t <- many' tuple4; return (Just $ map (Q Rel) t) }+parse_Q = do { AT.string "Q"; t <- many' tuple4; return (Just $ map (Q Abs) t) }+parse_t = do { AT.string "t"; t <- many' tuple2; return (Just $ map (T Rel) t) }+parse_T = do { AT.string "T"; t <- many' tuple2; return (Just $ map (T Abs) t) }+parse_a = do { AT.string "a"; t <- many' tuple7; return (Just $ map (A Rel) t) }+parse_A = do { AT.string "A"; t <- many' tuple7; return (Just $ map (A Abs) t) }++-- | In SVG values can be separated with a "," but don't have to be+withOptional parser a = do { AT.skipSpace;+ AT.choice [ do { AT.char a; b <- parser; return b},+ do { b <- parser; return b} ] }++doubleWithOptional a = do { d <- double `withOptional` a ; return (fromRational $ toRational d) }++spaceDouble = do { AT.skipSpace; d <- double; return (fromRational $ toRational d) }++tuple2 = do { a <- spaceDouble; b <- doubleWithOptional ','; return (a, b) }++tuple4 = do { a <- spaceDouble;+ b <- doubleWithOptional ',';+ c <- doubleWithOptional ',';+ d <- doubleWithOptional ',';+ return (a, b, c, d) }++tuple6 = do { a <- spaceDouble;+ b <- doubleWithOptional ',';+ c <- doubleWithOptional ',';+ d <- doubleWithOptional ',';+ e <- doubleWithOptional ',';+ f <- doubleWithOptional ','; return (a, b, c, d, e, f) }++tuple7 = do { a <- spaceDouble;+ b <- doubleWithOptional ',';+ c <- doubleWithOptional ',';+ d <- decimal `withOptional` ',';+ e <- decimal `withOptional` ',';+ f <- doubleWithOptional ',';+ g <- doubleWithOptional ',';+ return $ -- Debug.Trace.trace (show (a, b, c, fromIntegral d, fromIntegral e, f, g)) + (a, b, c, fromIntegral d, fromIntegral e, f, g) }+++-- | Convert a path string into path commands+commands :: (RealFloat n, Show n) => Maybe Text -> [PathCommand n]+commands = concat .+ catMaybes .+ (either (const []) id) .+ (AT.parseOnly (many' parsePathCommand)) .+ (fromMaybe T.empty)+++-- | Convert path commands into trails+commandsToPaths :: (RealFloat n, Show n) => [PathCommand n] -> [Path V2 n]+commandsToPaths pathCommands = map fst $ foldl' outline [] (splittedCommands pathCommands)+++-- | split list when there is a Z(closePath) and also when there is a (M)oveto command (keep the M)+-- and merge repeated lists of single Ms into one M command+splittedCommands pathCommands = concat $ map (S.split (S.keepDelimsR (S.whenElt isZ))) $ -- a path ends with a Z+ mergeMs $ -- now it is one M+ S.split (S.keepDelimsL (S.whenElt isM)) -- a path starts with Ms+ pathCommands+ where+ isM (M ar p) = True+ isM _ = False+ isZ Z = True+ isZ _ = False+ -- single Ms are a problem, because we would move something empty that we don't remember.+ mergeMs :: RealFloat n => [[PathCommand n]] -> [[PathCommand n]]+ mergeMs ( [M Rel (x,y)] : ( ((M Rel (x0,y0)):cs):ds ) ) = mergeMs (((M Rel (x+x0,y+y0)):cs):ds)+ mergeMs ( [M Rel (x,y)] : ( ((M Abs (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x0, y0)):cs):ds)+ mergeMs ( [M Abs (x,y)] : ( ((M Rel (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x+x0,y+y0)):cs):ds)+ mergeMs ( [M Abs (x,y)] : ( ((M Abs (x0,y0)):cs):ds ) ) = mergeMs (((M Abs (x0, y0)):cs):ds)+ mergeMs (c:cs) = c : (mergeMs cs)+ mergeMs [] = []++data ClosedTrail a = O a | Closed a+isClosed (Closed _) = True+isClosed _ = False++getTrail (Closed a) = a+getTrail (O a) = a++-- | Take the endpoint of the latest path, append another path that has been generated from the path commands+-- and return this whole path+outline :: (RealFloat n, Show n) => [(Path V2 n, (n, n))] -> [PathCommand n] -> [(Path V2 n, (n, n))]+outline paths cs = paths ++ [(newPath,newPoint)]+ where+ newPath = translate (r2 (trx,try)) $+ pathFromTrail $+ if isClosed trail+ then wrapLoop $ closeLine (mconcat (getTrail trail))+ else wrapLoop $ closeLine (mconcat (getTrail trail)) -- unfortunately this has to be closed also, + -- because some svgs fill paths that are open++ newPoint | isClosed trail = (trx, try) -- the endpoint is the old startpoint+ | otherwise = startPoint++ (ctrlPoint, startPoint, trail) = foldl' nextSegment ((x,y), (x,y), O []) cs++ (trx,try) | null cs = (0,0)+ | otherwise = sel2 $ nextSegment ((x,y), (x,y), O []) (head cs) -- cs usually always starts with a M-command,+ -- because we splitted the commands like that+ (x,y) | null paths = (0,0)+ | otherwise = snd (last paths)+ sel2 (a,b,c) = a+++-- | The last control point and end point of the last path are needed to calculate the next line to append+-- endpoint -> (controlPoint, startPoint, line) ->+nextSegment :: (RealFloat n, Show n) => ((n,n), (n,n), ClosedTrail [Trail' Line V2 n]) -> PathCommand n -> ( (n,n), (n,n), ClosedTrail [Trail' Line V2 n])+nextSegment (ctrlPoint, startPoint, O trail) Z = (ctrlPoint, startPoint, Closed trail)+nextSegment (_, _, _ ) (M Abs point) = (point, point, O [])+nextSegment (_, (x0,y0), _ ) (M Rel (x,y)) = ((x+x0, y+y0), (x+x0, y+y0), O [])+nextSegment (_, (x0,y0), O trail) (L Abs (x,y)) = ((x, y ), (x, y ), O $ trail ++ [straight' (x-x0, y-y0)])+nextSegment (_, (x0,y0), O trail) (L Rel (x,y)) = ((x+x0, y+y0), (x+x0, y+y0), O $ trail ++ [straight' (x, y )])+nextSegment (_, (x0,y0), O trail) (H Abs x) = ((x, y0), (x, y0), O $ trail ++ [straight' (x-x0, 0)])+nextSegment (_, (x0,y0), O trail) (H Rel x) = ((x+x0, y0), (x+x0, y0), O $ trail ++ [straight' (x, 0)])+nextSegment (_, (x0,y0), O trail) (V Abs y) = (( x0, y ), ( x0, y ), O $ trail ++ [straight' (0 , y-y0)])+nextSegment (_, (x0,y0), O trail) (V Rel y) = (( x0, y+y0), ( x0, y+y0), O $ trail ++ [straight' (0, y )])++nextSegment (_, (x0,y0), O trail) (C Abs (x1,y1,x2,y2,x,y)) = ((x2,y2), (x,y), O $ trail ++ [bez3 (x1-x0, y1-y0) (x2-x0, y2-y0) (x-x0,y-y0)])+nextSegment (_, (x0,y0), O trail) (C Rel (x1,y1,x2,y2,x,y)) = ((x2+x0, y2+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x1, y1) (x2, y2) (x,y)])++nextSegment ((cx,cy),(x0,y0), O trail) (S Abs (x2,y2,x,y)) = ((x2, y2), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x2-x0, y2-y0) (x-x0, y-y0)])+nextSegment ((cx,cy),(x0,y0), O trail) (S Rel (x2,y2,x,y)) = ((x2+x0, y2+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x0-cx, y0-cy) (x2, y2) (x, y)])++nextSegment (_, (x0,y0), O trail) (Q Abs (x1,y1,x,y)) = ((x1, y1), (x, y), O $ trail ++ [bez3 (x1-x0, y1-y0) (x-x0, y-y0) (x-x0, y-y0)])+nextSegment (_, (x0,y0), O trail) (Q Rel (x1,y1,x,y)) = ((x1+x0, y1+y0), (x+x0, y+y0), O $ trail ++ [bez3 (x1, y1) (x, y) (x, y)])++nextSegment ((cx,cy), (x0,y0), O trail) (T Abs (x,y)) = ((2*x0-cx, 2*y0-cy ), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x-x0, y-y0) (x-x0, y-y0)])+nextSegment ((cx,cy), (x0,y0), O trail) (T Rel (x,y)) = ((2*x0-cx, 2*y0-cy), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x, y) (x, y)])++nextSegment (_, (x0,y0), O trail) (A Abs (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)])+nextSegment (_, (x0,y0), O trail) (A Rel (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)])++nul = (0,0)++straight' = lineFromSegments . (:[]) . straight . r2++bez3 point1 point2 point3 = lineFromSegments [bezier3 (r2 point1) (r2 point2) (r2 point3)]++-- | The arc command: see <http://www.w3.org/TR/SVG11/implnote.html#ArcImplementationNotes>+-- To Do: scale if rx,ry,xAxisRot are such that there is no solution+svgArc :: (RealFloat n, Show n) => (n, n) -> n -> n -> n -> (n,n) -> Trail' Line V2 n+svgArc (rxx, ryy) xAxisRot largeArcFlag sweepFlag (x2, y2)+ | x2 == 0 && y2 == 0 = emptyLine -- spec F6.2+ | rx == 0 || ry == 0 = straight' (x2,y2) -- spec F6.2+ | otherwise = -- Debug.Trace.trace (show (dtheta) ++ show dir1) $+ unLoc (arc' 1 dir1 (dtheta @@ rad) # scaleY ry # scaleX rx # rotate (phi @@ rad))+ where rx | rxx < 0 = -rxx -- spec F6.2+ | otherwise = rxx+ ry | ryy < 0 = -ryy -- spec F6.2+ | otherwise = ryy+ fa | largeArcFlag == 0 = 0+ | otherwise = 1 -- spec F6.2+ fs | sweepFlag == 0 = 0+ | otherwise = 1 -- spec F6.2+ phi = xAxisRot * pi / 180+ (x1,y1) = (0,0)+ x1x2 = (x1 - x2)/2+ y1y2 = (y1 - y2)/2+ x1' = (cos phi) * x1x2 + (sin phi) * y1y2+ y1' = -(sin phi) * x1x2 + (cos phi) * y1y2+ s = (rx*rx*ry*ry - rx*rx*y1'*y1' - ry*ry*x1'*x1') / (rx*rx*y1'*y1' + ry*ry*x1'*x1' )+ root | s <= 0 = 0 -- Should only happen because of rounding errors, s usually being very close to 0+ | otherwise = sqrt s -- This bug happened: <https://ghc.haskell.org/trac/ghc/ticket/10010>+ cx' | fa /= fs = root * rx * y1' / ry+ | otherwise = - root * rx * y1' / ry+ cy' | fa /= fs = - root * ry * x1' / rx+ | otherwise = root * ry * x1' / rx+ cx = (cos phi) * cx' - (sin phi) * cy' + ((x1+x2)/2)+ cy = (sin phi) * cx' + (cos phi) * cy' + ((y1+y2)/2)+ dir1 = dirBetween (p2 ((x1'-cx')/rx, (y1'-cy')/ry)) origin+ v1 = r2 (( x1'-cx')/rx, (y1'-cy')/ry)+ v2 = r2 ((-x1'-cx')/rx, (-y1'-cy')/ry)+ -- angleV1V2 is unfortunately necessary probably because of something like <https://ghc.haskell.org/trac/ghc/ticket/10010>+ angleV1V2 | (signorm v1 `dot` signorm v2) >= 1 = (acosA 1 ) ^. rad+ | (signorm v1 `dot` signorm v2) <= -1 = (acosA (-1)) ^. rad+ | otherwise = (signedAngleBetween v2 v1) ^. rad+ dtheta | fs == 0 = if angleV1V2 > 0 then angleV1V2 - (2*pi) else angleV1V2+ | otherwise = if angleV1V2 < 0 then angleV1V2 + (2*pi) else angleV1V2+
+ src/Diagrams/SVG/ReadSVG.hs view
@@ -0,0 +1,1036 @@+{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GADTs,+ MultiParamTypeClasses, NoMonomorphismRestriction, OverloadedStrings, TypeFamilies, UndecidableInstances #-}++-------------------------------------------------------------------+-- |+-- Module : Diagrams.SVG.ReadSVG+-- Copyright : (c) 2015 Tillmann Vogt <tillk.vogt@googlemail.com>+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Maintainer : diagrams-discuss@googlegroups.com+-- Stability : stable+-- Portability: portable++-------------------------------------------------------------------++module Diagrams.SVG.ReadSVG+ (+ -- * Main functions+ readSVGFile+ , preserveAspectRatio+ , nodes+ , insertRefs+ , PreserveAR(..)+ , AlignSVG(..)+ , Place(..)+ , MeetOrSlice(..)+ , InputConstraints(..)+ -- * Parsing of basic structure tags+ , parseSVG+ , parseG+ , parseDefs+ , parseSymbol+ , parseUse+ , parseSwitch+ , parseDesc+ , parseTitle+-- , parseMetaData+ -- * Parsing of basic shape tags+ , parseRect+ , parseCircle+ , parseEllipse+ , parseLine+ , parsePolyLine+ , parsePolygon+ , parsePath+ -- * Parsing of Gradient tags+ , parseLinearGradient+ , parseRadialGradient+ , parseSet+ , parseStop+ -- * Parsing of other tags+ , parseClipPath+ , parsePattern+ , parseFilter+ , parseImage+ , parseText+ -- * Parsing data uri in <image>+ , dataUriToImage+ ) where++import Codec.Picture+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Control.Monad.Trans.Class+import Data.Either.Combinators+import qualified Data.Attoparsec.Text as AT+import qualified Data.Attoparsec.ByteString as ABS+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as Base64+import Data.Conduit+import qualified Data.Conduit.List as CL+import qualified Data.Colour+import qualified Data.Conduit.List as C+import qualified Data.HashMap.Strict as H+import Data.Maybe (fromJust, fromMaybe, isJust)+import qualified Data.Text as T+import Data.Text(Text(..))+import Data.Text.Encoding+import Data.Typeable (Typeable)+import Data.XML.Types+import Diagrams.Attributes+import Diagrams.Prelude+import Diagrams.TwoD.Ellipse+import Diagrams.TwoD.Path (isInsideEvenOdd)+import Diagrams.TwoD.Size+import Diagrams.TwoD.Types+import qualified Diagrams.TwoD.Text as TT+import Diagrams.SVG.Arguments+import Diagrams.SVG.Attributes+import Diagrams.SVG.Fonts.ReadFont+import Diagrams.SVG.Path (commands, commandsToPaths, PathCommand(..))+import Diagrams.SVG.Tree+import Filesystem.Path (FilePath(..), extension)+import Filesystem.Path.CurrentOS (encodeString)+import Prelude hiding (FilePath)+import Text.XML.Stream.Parse hiding (parseText)+import Text.CSS.Parse (parseBlocks)++import Debug.Trace+--------------------------------------------------------------------------------------+-- | Main library function+-- +-- @+-- \{-\# LANGUAGE OverloadedStrings \#-\}+--+-- module Main where+-- import Diagrams.SVG.ReadSVG+-- import Diagrams.Prelude+-- import Diagrams.Backend.SVG.CmdLine+-- import System.Environment+-- import Filesystem.Path.CurrentOS+-- import Diagrams.SVG.Attributes (PreserveAR(..), AlignSVG(..), Place(..), MeetOrSlice(..))+--+-- main = do+-- diagramFromSVG <- readSVGFile \"svgs/web.svg\"+-- mainWith $ diagramFromSVG+-- @+--+readSVGFile :: (V b ~ V2, N b ~ n, RealFloat n, Renderable (Path V2 n) b, Renderable (DImage n Embedded) b, -- TODO upper example+ Typeable b, Typeable n, Show n, Read n, n ~ Place, Renderable (TT.Text n) b) + => Filesystem.Path.FilePath -> IO (Either String (Diagram b))+readSVGFile fp = if (extension fp) /= (Just "svg") then return $ Left "Not a svg file" else -- TODO All exceptions into left values+ runResourceT $ do tree <- parseFile def (encodeString fp) $$ force "error in parseSVG" parseSVG+ return (Right (diagram tree))++diagram :: (RealFloat n, V b ~ V2, n ~ N b, Typeable n, Read n, n ~ Place) => Tag b n -> Diagram b+diagram tr = (insertRefs ((nmap,cssmap,expandedGradMap),(0,0,100,100)) tr) # scaleY (-1) # initialStyles+ where+ (ns,css,grad,fonts) = nodes Nothing ([],[],[], []) tr+ nmap = H.fromList ns -- needed because of the use-tag and clipPath+ cssmap = H.fromList css -- CSS inside the <defs> tag+ gradmap = H.fromList grad+ expandedGradMap = expandGradMap gradmap+++-- | Read font data from font file, and compute its outline map.+--+{-+loadFont :: (Read n, RealFloat n) => FilePath -> IO (Either String (PreparedFont n))+loadFont filename = if (extension fp) /= (Just "svg") then return $ Left "Not a svg file" else -- TODO All exceptions into left values+ runResourceT $ runEitherT $ do+ tree <- lift (parseFile def fp $$ force "error in parseSVG" parseSVG)+ let fontData = font tree+ case fontData of Left s -> return (Left s)+ Right s -> do let (font, errs) = prepareFont fontData+ sequence_ [ putStrLn ("error parsing character '" ++ ch ++ "': " ++ err)+ | (ch, err) <- Map.toList errs+ ]+ return font++font tr = fonts+ where (ns,css,grad,fonts) = nodes Nothing ([],[],[], []) tr+-}+-------------------------------------------------------------------------------------+-- Basic SVG structure++tagName name = tag' (Text.XML.Stream.Parse.matching (== name))++class (V b ~ V2, N b ~ n, RealFloat n, Renderable (Path V2 n) b, Typeable n, Typeable b, Show n,+ Renderable (DImage n Embedded) b) => InputConstraints b n++instance (V b ~ V2, N b ~ n, RealFloat n, Renderable (Path V2 n) b, Typeable n, Typeable b, Show n,+ Renderable (DImage n Embedded) b) => InputConstraints b n++-- | Parse \<svg\>, see <http://www.w3.org/TR/SVG/struct.html#SVGElement>+parseSVG :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Sink Event m (Maybe (Tag b n))+parseSVG = tagName "{http://www.w3.org/2000/svg}svg" svgAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,x,y,w,h,vb,ar,zp,ver,baseprof,cScripT,cStyleT,xmlns,xml) ->+ do gs <- many gContent+ let st hmaps = (parseStyles style hmaps) ++ -- parse the style attribute (style="stop-color:#000000;stop-opacity:0.8")+ (parsePA pa hmaps) ++ -- presentation attributes: stop-color="#000000" stop-opacity="0.8"+ (cssStylesFromMap hmaps "svg" (id1 ca) class_)+ let pw = if (isJust w) then parseDouble $ fromJust w else 0+ let ph = if (isJust h) then parseDouble $ fromJust h else 0+ return $ -- Debug.Trace.trace ("@" ++ show vb ++ show (parseViewBox vb w h)) (+ SubTree True (id1 ca)+ (pw,ph)+ (parseViewBox vb w h)+ (parsePreserveAR ar)+ (applyStyleSVG st)+ (reverse gs)++svgContent :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n))+svgContent = choose -- the likely most common are checked first+ [parseG, parsePath, parseCircle, parseRect, parseEllipse, parseLine, parsePolyLine, parsePolygon,+ parseDefs, parseSymbol, parseUse, -- structural elements+ parseClipPath, parsePattern, parseImage, parseText, -- parseSwitch, parseSodipodi,+ skipArbitraryTag] -- should always be last!+ -- parseDesc, parseMetaData, parseTitle] -- descriptive Elements++---------------------------------------------------------------------------+-- | Parse \<g\>, see <http://www.w3.org/TR/SVG/struct.html#GElement>+parseG :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n))+parseG = tagName "{http://www.w3.org/2000/svg}g" gAttrs+ $ \(cpa,ca,gea,pa,class_,style,ext,tr) ->+ do insideGs <- many gContent+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "g" (id1 ca) class_)+ return $ SubTree True (id1 ca)+ (0, 0)+ Nothing+ Nothing+ (\maps -> (applyStyleSVG st maps) . (applyTr (parseTr tr)) )+ (reverse insideGs)++gContent :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (Tag b n))+gContent = choose -- the likely most common are checked first+ [parsePath, parseG, parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePolygon,+ parseUse, parseSymbol, parseStyle, parseDefs, -- structural elements+ parseClipPath, parseLinearGradient, parseRadialGradient, parseImage, parseText, -- parseFont,+ skipArbitraryTag] -- -- should always be last!+-- parseFilter, parsePattern, parseSwitch, parsePerspective,+-- parseDesc, parseMetaData, parseTitle, parsePathEffect] -- descriptive Elements++---------------------------------------------------------------------------+-- | Parse \<defs\>, see <http://www.w3.org/TR/SVG/struct.html#DefsElement>+parseDefs :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n))+parseDefs = tagName "{http://www.w3.org/2000/svg}defs" gAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr) ->+ do insideDefs <- many gContent+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "defs" (id1 ca) class_)+ return $ SubTree False (id1 ca)+ (0, 0)+ Nothing+ Nothing+ ( (applyTr (parseTr tr)) . (applyStyleSVG st) )+ (reverse insideDefs)++---------------------------------------------------------------------------+-- | Parse \<defs\>, see <http://www.w3.org/TR/SVG/struct.html#DefsElement>+-- e.g.+-- <style type="text/css">+-- <![CDATA[+-- .fil0 {fill:#FEFEFE}+-- .fil1 {fill:#3A73B8}+-- ]]>+-- </style>+parseStyle :: (MonadThrow m, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseStyle = tagName "{http://www.w3.org/2000/svg}style" sAttrs $+ \(ca,type_,media,title) ->+ do insideStyle <- content+ let blocks = parseBlocks insideStyle -- parseBlocks :: Text -> Either String [CssBlock]+ let cssBlocks = case blocks of+ Left err -> []+ Right st -> st+ return $ StyleTag cssBlocks -- type CssBlock = (Text, [(Text, Text)]) = (selector, [(attribute, value)])++-----------------------------------------------------------------------------------+-- | Parse \<symbol\>, see <http://www.w3.org/TR/SVG/struct.html#SymbolElement>+parseSymbol :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) + => Consumer Event m (Maybe (Tag b n))+parseSymbol = tagName "{http://www.w3.org/2000/svg}symbol" symbolAttrs $+ \(ca,gea,pa,class_,style,ext,ar,viewbox) ->+ do insideSym <- many gContent+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "symbol" (id1 ca) class_)+ return $ SubTree False (id1 ca)+ (0, 0)+ (parseViewBox viewbox Nothing Nothing)+ (parsePreserveAR ar)+ (applyStyleSVG st)+ (reverse insideSym)++-----------------------------------------------------------------------------------+-- | Parse \<use\>, see <http://www.w3.org/TR/SVG/struct.html#UseElement>+parseUse :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Typeable n) => Consumer Event m (Maybe (Tag b n))+parseUse = tagName "{http://www.w3.org/2000/svg}use" useAttrs+ $ \(ca,cpa,gea,pa,xlink,class_,style,ext,tr,x,y,w,h) ->+ do -- insideUse <- many useContent+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "use" (id1 ca) class_)+ let path (minx,miny,vbW,vbH) = rect (p (minx,vbW) 0 w) (p (miny,vbH) 0 h)+ return $ Reference (id1 ca)+ (Diagrams.SVG.Attributes.fragment $ xlinkHref xlink)+ path+ (f tr x y st) -- f gets supplied with the missing maps an viewbox when evaluating the Tag-tree+ where -- f :: Maybe Text -> Maybe Text -> Maybe Text -> (HashMaps b n -> [SVGStyle n a]) + -- -> (HashMaps b n, (n,n,n,n)) -> Diagram b -> Diagram b+ f tr x y st (maps,(minx,miny,vbW,vbH)) = (translate (r2 (p (vbW, minx) 0 x, + p (vbH, miny) 0 y))) .+ (applyTr (parseTr tr)) . (applyStyleSVG st maps)++useContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+useContent = choose [parseDesc,parseTitle] -- descriptive elements++--------------------------------------------------------------------------------------+-- | Parse \<switch\>, see <http://www.w3.org/TR/SVG/struct.html#SwitchElement>+parseSwitch :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseSwitch = tagName "{http://www.w3.org/2000/svg}switch" switchAttrs+ $ \(cpa,ca,gea,pa,class_,style,ext,tr) ->+ do -- insideSwitch <- many switchContent+ return $ Leaf (id1 ca) mempty mempty++-- switchContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+switchContent = choose [parsePath, parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePolygon]++-----------------------------------------------------------------------------------+-- | Parse \<rect\>, see <http://www.w3.org/TR/SVG11/shapes.html#RectElement>+parseRect :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseRect = tagName "{http://www.w3.org/2000/svg}rect" rectAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,ar,tr,x,y,w,h,rx,ry) -> do+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "rect" (id1 ca) class_)+ let rRect pw ph prx pry | prx == 0 && pry == 0 = rect pw ph+ | otherwise = roundedRect pw ph (if prx == 0 then pry else prx)+ let path (minx,miny,vbW,vbH) = (rRect (p (minx,vbW) 0 w) (p (miny,vbH) 0 h)+ (p (minx,vbW) 0 rx) (p (miny,vbH) 0 ry))+ # alignBL+ # applyTr (parseTr tr)+ # translate (r2 (p (minx,vbW) 0 x, p (miny,vbH) 0 y))+ let f (maps,viewbox) = path viewbox # stroke # applyStyleSVG st maps+ return $ Leaf (id1 ca) path f++---------------------------------------------------------------------------------------------------+-- | Parse \<circle\>, see <http://www.w3.org/TR/SVG11/shapes.html#CircleElement>+parseCircle :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseCircle = tagName "{http://www.w3.org/2000/svg}circle" circleAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr,r,cx,cy) -> do+ let -- st :: (RealFloat n, RealFloat a, Read a) => (HashMaps b n, ViewBox n) -> [SVGStyle n a]+ st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "circle" (id1 ca) class_)+ let path (minx,miny,w,h) = circle (p (minx,w) 0 r) -- TODO: radius of a circle in percentages (relative to x?)+ # applyTr (parseTr tr)+ # translate (r2 (p (minx,w) 0 cx, p (miny,h) 0 cy))+ let f (maps,viewbox) = path viewbox # stroke # applyStyleSVG st maps+ return $ Leaf (id1 ca) path f++---------------------------------------------------------------------------------------------------+-- | Parse \<ellipse\>, see <http://www.w3.org/TR/SVG11/shapes.html#EllipseElement>+parseEllipse :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseEllipse = tagName "{http://www.w3.org/2000/svg}ellipse" ellipseAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr,rx,ry,cx,cy) -> do+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "ellipse" (id1 ca) class_)+ let path (minx,miny,w,h) = ((ellipseXY (p (minx,w) 0 rx) (p (miny,h) 0 ry) ))+ # applyTr (parseTr tr)+ # translate (r2 (p (minx,w) 0 cx, p (miny,h) 0 cy))+ let f (maps,viewbox) = path viewbox # stroke # applyStyleSVG st maps+ return $ Leaf (id1 ca) path f++---------------------------------------------------------------------------------------------------+-- | Parse \<line\>, see <http://www.w3.org/TR/SVG11/shapes.html#LineElement>+parseLine :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseLine = tagName "{http://www.w3.org/2000/svg}line" lineAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr,x1,y1,x2,y2) -> do+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "line" (id1 ca) class_)+ let path (minx,miny,w,h) = (fromSegments [ straight (r2 ((p (minx,w) 0 x2) - (p (minx,w) 0 x1), + (p (miny,h) 0 y2) - (p (miny,h) 0 y1))) ])+ # applyTr (parseTr tr)+ # translate (r2 (p (minx,w) 0 x1, p (miny,h) 0 y1))+ let f (maps,viewbox) = path viewbox # stroke+ # applyStyleSVG st maps+ return $ Leaf (id1 ca) path f++---------------------------------------------------------------------------------------------------+-- | Parse \<polyline\>, see <http://www.w3.org/TR/SVG11/shapes.html#PolylineElement>+parsePolyLine :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parsePolyLine = tagName "{http://www.w3.org/2000/svg}polyline" polygonAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr,points) -> do+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "polyline" (id1 ca) class_)+ let ps = parsePoints (fromJust points)+ let path viewbox = fromVertices (map p2 ps) # translate (r2 (head ps))+ # applyTr (parseTr tr)++ let f (maps,viewbox) = fromVertices (map p2 ps) # strokeLine+ # translate (r2 (head ps))+ # applyTr (parseTr tr)+ # applyStyleSVG st maps+ return $ Leaf (id1 ca) path f++--------------------------------------------------------------------------------------------------+-- | Parse \<polygon\>, see <http://www.w3.org/TR/SVG11/shapes.html#PolygonElement>+parsePolygon :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parsePolygon = tagName "{http://www.w3.org/2000/svg}polygon" polygonAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr,points) -> do+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "polygon" (id1 ca) class_)+ let ps = parsePoints (fromJust points)+ let path viewbox = fromVertices (map p2 ps) # translate (r2 (head ps))+ # applyTr (parseTr tr)+ let f (maps,viewbox) = fromVertices (map p2 ps) # closeLine+ # strokeLoop+ # translate (r2 (head ps))+ # applyTr (parseTr tr)+ # applyStyleSVG st maps+ return $ Leaf (id1 ca) path f++--------------------------------------------------------------------------------------------------+-- | Parse \<path\>, see <http://www.w3.org/TR/SVG11/paths.html#PathElement>+parsePath :: (MonadThrow m, InputConstraints b n, Show n) => Consumer Event m (Maybe (Tag b n))+parsePath = tagName "{http://www.w3.org/2000/svg}path" pathAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr,d,pathLength) -> do+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "path" (id1 ca) class_)+ let path viewbox = (mconcat $ commandsToPaths $ commands d) # applyTr (parseTr tr)+ let f (maps,viewbox) = path viewbox # strokePath+ # applyStyleSVG st maps+ return $ Leaf (id1 ca) path f++-------------------------------------------------------------------------------------------------+-- | Parse \<clipPath\>, see <http://www.w3.org/TR/SVG/masking.html#ClipPathElement>+parseClipPath :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (Tag b n))+parseClipPath = tagName "{http://www.w3.org/2000/svg}clipPath" clipPathAttrs $+ \(cpa,ca,pa,class_,style,ext,ar,viewbox) -> do+ insideClipPath <- many clipPathContent+ let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "clipPath" (id1 ca) class_)+ return $ SubTree False (id1 ca)+ (0, 0)+ (parseViewBox viewbox Nothing Nothing)+ (parsePreserveAR ar)+ (applyStyleSVG st)+ (reverse insideClipPath)++clipPathContent :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (Tag b n))+clipPathContent = choose [parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePath,+ parsePolygon, parseText, parseUse]++--------------------------------------------------------------------------------------+-- | Parse \<image\>, see <http://www.w3.org/TR/SVG/struct.html#ImageElement>+-- <image width="28" xlink:href="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABwAAAADCAYAAACAjW/aAAAABmJLR0QA/wD/AP+gvaeTAAAAB3RJTUUH2AkMDx4ErQ9V0AAAAClJREFUGJVjYMACGhoa/jMwMPyH0kQDYvQxYpNsaGjAyibCQrL00dSHACypIHXUNrh3AAAAAElFTkSuQmCC" height="3"/>+parseImage :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Renderable (DImage (N b) Embedded) b,+ Typeable b, Typeable n) => Consumer Event m (Maybe (Tag b n))+parseImage = tagName "{http://www.w3.org/2000/svg}image" imageAttrs $+ \(ca,cpa,gea,xlink,pa,class_,style,ext,ar,tr,x,y,w,h) ->+ do return $ Leaf (id1 ca) mempty (\(_,(minx,miny,vbW,vbH)) -> (dataUriToImage (xlinkHref xlink) (p (minx,vbW) 0 w) (p (miny,vbH) 0 h))+ # alignBL+ # applyTr (parseTr tr)+ # translate (r2 (p (minx,vbW) 0 x, p (miny,vbH) 0 y)))+-- TODO aspect ratio++data ImageType = JPG | PNG | SVG++---------------------------------------------------------------------------------------------------+-- | Convert base64 encoded data in <image> to a Diagram b with JuicyPixels+-- input: "data:image/png;base64,..."+dataUriToImage :: (Metric (V b), Ord n, RealFloat n, N b ~ n, V2 ~ V b, Renderable (DImage n Embedded) b,+ Typeable b, Typeable n) => Maybe Text -> n -> n -> Diagram b+dataUriToImage _ 0 h = mempty+dataUriToImage _ w 0 = mempty+dataUriToImage Nothing w h = mempty+dataUriToImage (Just text) w h = either (const mempty) id $ ABS.parseOnly dataUri (encodeUtf8 text)+ where+ jpg = do { ABS.string "jpg"; return JPG } -- ABS = Data.Attoparsec.ByteString+ png = do { ABS.string "png"; return PNG }+ svg = do { ABS.string "svg"; return SVG }++ dataUri = do+ ABS.string "data:image/"+ imageType <- ABS.choice [jpg, png, svg]+ ABS.string ";base64," -- assuming currently that this is always used+ base64data <- ABS.many1 ABS.anyWord8+ return $ case im imageType (B.pack base64data) of+ Right img -> image (DImage (ImageRaster img) (round w) (round h) mempty)+ Left x -> mempty++im :: ImageType -> B.ByteString -> Either String DynamicImage+im imageType base64data = case Base64.decode base64data of+ Left _ -> Left "diagrams-input: Error decoding data uri in <image>-tag"+ Right b64 -> case imageType of+ JPG -> decodeJpeg b64 -- decodeJpeg :: ByteString -> Either String DynamicImage+ PNG -> decodePng b64+ -- SVG -> preserveAspectRatio w h oldWidth oldHeight ar (readSVGBytes base64data) -- something like that+ _ -> Left "diagrams-input: format not supported in <image>-tag"++-------------------------------------------------------------------------------------------------+-- | Parse \<text\>, see <http://www.w3.org/TR/SVG/text.html#TextElement>+parseText :: (MonadThrow m, InputConstraints b n, Read n, RealFloat n, Renderable (TT.Text n) b)+ => Consumer Event m (Maybe (Tag b n))+parseText = tagName "{http://www.w3.org/2000/svg}text" textAttrs $+ \(cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) ->+ do let st hmaps = (parseStyles style hmaps) +++ (parsePA pa hmaps) +++ (cssStylesFromMap hmaps "text" (id1 ca) class_)+ insideText <- many (tContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen))+ return $ SubTree True (id1 ca)+ (0, 0)+ Nothing+ Nothing+ (\maps -> applyStyleSVG st maps)+ insideText++tContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen)+ = choose+ [ parseTSpan (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen),+ textContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) ]+++{-+-- text related data of pa (presentation attribute)++alignmentBaseline baselineShift dominantBaseline fontFamily+fntSize fontSizeAdjust fontStretch fontStyle fontVariant fontWeight+glyphOrientationHorizontal glyphOrientationVertical kerning letterSpacing+textAnchor textDecoration textRendering wordSpacing writingMode+-}++-- | Parse a string between the text tags: \<text\>Hello\</text\>+textContent :: (MonadThrow m, InputConstraints b n, RealFloat n, Read n, Renderable (TT.Text n) b) =>+ (ConditionalProcessingAttributes,+ CoreAttributes,+ GraphicalEventAttributes,+ PresentationAttributes,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text) -> ConduitM Event o m (Maybe (Tag b n))+textContent (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) =+ do t <- contentMaybe+ let st :: (Read a, RealFloat a, RealFloat n) => (HashMaps b n, ViewBox n) -> [(SVGStyle n a)]+ st (hmaps,_) = (parseStyles style hmaps) +++ (parsePA pa hmaps)++ let f :: (V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable n, Renderable (TT.Text n) b)+ => (HashMaps b n, ViewBox n) -> Diagram b+ f (maps,(minx,miny,w,h)) = anchorText pa (maybe "" T.unpack t)+ -- fontWeight+ # scaleY (-1)+ # translate (r2 (p (minx,w) 0 x, p (miny,h) 0 y))+ # (applyTr (parseTr tr))+ # applyStyleSVG st (maps,(minx,miny,w,h))+ # maybe id (fontSize . local . read . T.unpack) (fntSize pa)+ # maybe id (font . T.unpack) (fontFamily pa)++ return (if isJust t then Just $ Leaf (id1 ca) mempty f+ else Nothing)+++{-<tspan+ sodipodi:role="line"+ id="tspan2173"+ x="1551.4218"+ y="1056.9836" /> -}++-------------------------------------------------------------------------------------------------+-- | Parse \<tspan\>, see <https://www.w3.org/TR/SVG/text.html#TSpanElement>+parseTSpan :: (MonadThrow m, InputConstraints b n, RealFloat n, Read n, Renderable (TT.Text n) b) =>+ (ConditionalProcessingAttributes,+ CoreAttributes,+ GraphicalEventAttributes,+ PresentationAttributes,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text,+ Maybe Text) -> ConduitM Event o m (Maybe (Tag b n))+parseTSpan (cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) = tagName "{http://www.w3.org/2000/svg}tspan" tspanAttrs $+ \(cpa1,ca1,gea1,pa1,class1,style1,ext1,x1,y1,dx1,dy1,rot1,textlen1,lAdjust1,role) ->+ do t <- contentMaybe+ let st :: (Read a, RealFloat a, RealFloat n) => (HashMaps b n, ViewBox n) -> [(SVGStyle n a)]+ st (hmaps,_) = (parseStyles style hmaps) +++ (parseStyles style1 hmaps) +++ (parsePA pa hmaps) +++ (parsePA pa1 hmaps) +++ (cssStylesFromMap hmaps "tspan" (id1 ca) class_)++ let f :: (V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable n, Renderable (TT.Text n) b)+ => (HashMaps b n, ViewBox n) -> Diagram b+ f (maps,(minx,miny,w,h)) = anchorText pa (maybe "" T.unpack t)+ # maybe id (fontSize . local . read . T.unpack) (pref (fntSize pa1) (fntSize pa))+ # maybe id (font . T.unpack) (pref (fontFamily pa1) (fontFamily pa))+ -- fontWeight+ # scaleY (-1)+ # translate (r2 (p (minx,w) 0 (pref x1 x), p (miny,h) 0 (pref y1 y)))+ # (applyTr (parseTr tr))+ # applyStyleSVG st (maps,(minx,miny,w,h))+ return $ Leaf (id1 ca) mempty f+++anchorText :: (V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable n, Renderable (TT.Text n) b)+ => PresentationAttributes -> String -> QDiagram b V2 n Any+anchorText pa txt = case anchor pa of + "start" -> baselineText txt+ "middle" -> text txt+ "end" -> alignedText 1 0 txt -- TODO is this correct?+ "inherit" -> text txt -- TODO+ where+ anchor pa = maybe "start" T.unpack (textAnchor pa) -- see <https://www.w3.org/TR/SVG/text.html#TextAnchorProperty>+++pref :: Maybe a -> Maybe a -> Maybe a+pref (Just x) b = Just x+pref Nothing (Just y) = Just y+pref Nothing Nothing = Nothing+++--------------------------------------------------------------------------------------+-- Gradients+-------------------------------------------------------------------------------------++-- | Parse \<linearGradient\>, see <http://www.w3.org/TR/SVG/pservers.html#LinearGradientElement>+-- example: <linearGradient id="SVGID_2_" gradientUnits="userSpaceOnUse" x1="68.2461" y1="197.6797"+-- x2="52.6936" y2="237.5337" gradientTransform="matrix(1 0 0 -1 -22.5352 286.4424)">+parseLinearGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseLinearGradient = tagName "{http://www.w3.org/2000/svg}linearGradient" linearGradAttrs $+ \(ca,pa,xlink,class_,style,ext,x1,y1,x2,y2,gradientUnits,gradientTransform,spreadMethod) -> -- TODO gradientUnits+ do gs <- many gradientContent+ let stops = map getTexture $ concat $ map extractStops gs++ -- because of href we have to replace Nothing-attributes by attributes of referenced gradients+ -- see <http://www.w3.org/TR/SVG/pservers.html#RadialGradientElementHrefAttribute>+ let attributes = GA pa class_ style x1 y1 x2 y2 Nothing Nothing Nothing Nothing Nothing gradientUnits gradientTransform spreadMethod++ -- stops are lists of functions and everyone of these gets passed the same cssmap+ -- and puts them into a Grad constructor+ let f css attributes (minx,miny,w,h) stops =+ over (_LG . lGradTrans) (applyTr (parseTr gradientTransform))+ (mkLinearGradient (concat (map ($ css) stops)) -- (minx,miny,w,h) is the viewbox+ ((p (minx,w) 0 x1) ^& (p (miny,h) 0 y1))+ ((p (minx,w) 0 x2) ^& (p (miny,h) 0 y2))+ (parseSpread spreadMethod))+ return $ Grad (id1 ca) (Gr (Diagrams.SVG.Attributes.fragment $ xlinkHref xlink) attributes Nothing stops f)++gradientContent = choose [parseStop, parseMidPointStop] -- parseSet,+ -- parseDesc, parseMetaData, parseTitle] -- descriptive Elements (rarely used here, so tested at the end)++-- | Parse \<radialGradient\>, see <http://www.w3.org/TR/SVG/pservers.html#RadialGradientElement>+parseRadialGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseRadialGradient = tagName "{http://www.w3.org/2000/svg}radialGradient" radialGradAttrs $ -- TODO gradientUnits+ \(ca,pa,xlink,class_,style,ext,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod) -> + do gs <- many gradientContent+ let stops = map getTexture $ concat $ map extractStops gs++ -- because of href we have to replace Nothing-attributes by attributes of referenced gradients+ -- see <http://www.w3.org/TR/SVG/pservers.html#RadialGradientElementHrefAttribute>+ let attributes = GA pa class_ style Nothing Nothing Nothing Nothing cx cy r fx fy gradientUnits gradientTransform spreadMethod++ let f css attributes (minx,miny,w,h) stops =+ over (_RG . rGradTrans) (applyTr (parseTr gradientTransform))+ (mkRadialGradient (concat (map ($ css) stops))+ ((p (minx,w) (p (minx,w) 0 cx) fx) ^& -- focal point fx is set to cx if fx does not exist+ (p (miny,h) (p (miny,h) 0 cy) fy))+ 0+ ((p (minx,w) 0 cx) ^& + (p (miny,h) 0 cy))+ (p (minx,w) (0.5*(w-minx)) r) --TODO radius percentage relative to x or y?+ (parseSpread spreadMethod))+ return $ Grad (id1 ca) (Gr (Diagrams.SVG.Attributes.fragment $ xlinkHref xlink) attributes Nothing stops f)++extractStops (SubTree b id1 wh viewBox ar f children) = concat (map extractStops children)+extractStops (Stop stops) = [Stop stops]+extractStops _ = []++getTexture :: (RealFloat n) => Tag b n -> (CSSMap -> [GradientStop n])+getTexture (Stop stops) = stops . (\css -> (H.empty, css, H.empty))++-- | Parse \<set\>, see <http://www.w3.org/TR/SVG/animate.html#SetElement>+parseSet = tagName "{http://www.w3.org/2000/svg}set" setAttrs $+ \(ca,pa,xlink) ->+ do return $ Leaf (id1 ca) mempty mempty -- "set" ignored so far++-- | Parse \<stop\>, see <http://www.w3.org/TR/SVG/pservers.html#StopElement>+-- e.g. <stop offset="0.4664" style="stop-color:#000000;stop-opacity:0.8"/>+parseStop = tagName "{http://www.w3.org/2000/svg}stop" stopAttrs $+ \(ca,pa,xlink,class_,style,offset) ->+ do let st hmaps = (parseStyles style empty3) +++ (parsePA pa empty3) +++ (cssStylesFromMap hmaps "stop" (id1 ca) class_)+ return $ Stop (\hmaps -> mkStops [getStopTriple (p (0,1) 0 offset) (st hmaps)])++parseMidPointStop = tagName "{http://www.w3.org/2000/svg}midPointStop" stopAttrs $+ \(ca,pa,xlink,class_,style,offset) ->+ do let st hmaps = (parseStyles style empty3) +++ (parsePA pa empty3) +++ (cssStylesFromMap hmaps "midPointStop" (id1 ca) class_)+ return $ Stop (\hmaps -> mkStops [getStopTriple (p (0,1) 0 offset) (st hmaps)])++empty3 = (H.empty,H.empty,H.empty)++getStopTriple offset styles = (col colors, offset, opacity opacities)+ where col ((Fill c):_) = fromAlphaColour c+ col _ = white+ opacity ((FillOpacity x):_) = x+ opacity _ = 1+ colors = Prelude.filter isFill styles+ opacities = Prelude.filter isOpacity styles++isFill (Fill _) = True+isFill _ = False++isOpacity (FillOpacity _) = True+isOpacity _ = False++----------------------------------------------------------------------------------------------------+-- Fonts+----------------------------------------------------------------------------------------------------++parseFont :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Renderable (DImage (N b) Embedded) b, Renderable (Path V2 n) b,+ Typeable b, Typeable n, Show n, Read n, Renderable (TT.Text n) b) => Consumer Event m (Maybe (Tag b n))+parseFont = tagName "{http://www.w3.org/2000/svg}font" fontAttrs $+ \(ca,pa,class_,style,ext,hOriginX,hOriginY,hAdvX,vOriginX,vOriginY,vAdvY) ->+ do gs <- many fontContent+ return $ FontTag $ FontData (id1 ca) hOriginX hOriginY (getN hAdvX) vOriginX vOriginY vAdvY + (fontf gs) (missingGlyph gs) (glyphs gs) (kernMap (kerns gs))+ where fontf gs = (\(FF f) -> f) $ head $ Prelude.filter isFontFace gs+ missingGlyph gs = (\(GG g) -> g) $ head $ Prelude.filter isMissingGlyph gs+ glyphs gs = H.fromList $ map toSvgGlyph (Prelude.filter isGlyph gs)+ kerns gs = map (\(KK k) -> k) (Prelude.filter isKern gs)++ isGlyph (GG (Glyph glyphId g d _ _ _ _ unicode glyphName o a l)) = not (maybe False T.null unicode) ||+ not (maybe False T.null glyphName)+ isGlyph _ = False+ isMissingGlyph (GG (Glyph glyphId g d _ _ _ _ unicode glyphName o a l)) = (maybe False T.null unicode) &&+ (maybe False T.null glyphName)+ isMissingGlyph _ = False+ isKern (KK k) = True+ isKern _ = False+ isFontFace (FF f) = True+ isFontFace _ = False+ toSvgGlyph (GG (Glyph glyphId g d horizAdvX _ _ _ (Just unicode) glyphName o a l)) = (unicode,(glyphName,horizAdvX,d))++fontContent :: (MonadThrow m, InputConstraints b n, Read n, Show n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (FontContent b n))+fontContent = choose -- the likely most common are checked first+ [parseGlyph, parseHKern, parseFontFace, parseMissingGlyph, parseVKern]+++parseFontFace :: (MonadThrow m, V b ~ V2, N b ~ n, Read n, RealFloat n, Renderable (DImage (N b) Embedded) b,+ Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+parseFontFace = tagName "{http://www.w3.org/2000/svg}font-face" fontFaceAttrs $+ \(ca,fontFamily,fontStyle,fontVariant,fontWeight,fontStretch,fontSize,unicodeRange,unitsPerEm,panose1,+ stemv,stemh,slope,capHeight,xHeight,accentHeight,ascent,descent,widths,bbox,ideographic,alphabetic,mathematical,+ hanging,vIdeographic,vAlphabetic,vMathematical,vHanging,underlinePosition,underlineThickness,strikethroughPosition,+ strikethroughThickness,overlinePosition,overlineThickness) ->+ do return $ FF $ FontFace fontFamily fontStyle fontVariant fontWeight fontStretch fontSize unicodeRange unitsPerEm panose1+ stemv stemh slope capHeight xHeight accentHeight ascent descent widths (parseBBox bbox) ideographic+ alphabetic mathematical hanging vIdeographic vAlphabetic vMathematical vHanging underlinePosition + underlineThickness strikethroughPosition strikethroughThickness overlinePosition overlineThickness+++parseMissingGlyph :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Renderable (DImage (N b) Embedded) b,+ Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+parseMissingGlyph = tagName "{http://www.w3.org/2000/svg}missing-glyph" missingGlyphAttrs $+ \(ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY) ->+ do return $ GG $ Glyph (id1 ca) (Leaf (id1 ca) mempty mempty) Nothing+ (getN horizAdvX) (getN vertOriginX) (getN vertOriginY) (getN vertAdvY)+ Nothing Nothing Nothing Nothing Nothing+++parseGlyph :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Renderable (DImage (N b) Embedded) b,+ Renderable (Path V2 n) b, Show n, Typeable b, Typeable n, Renderable (TT.Text n) b) + => Consumer Event m (Maybe (FontContent b n))+parseGlyph = tagName "{http://www.w3.org/2000/svg}glyph" glyphAttrs $+ \(ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY,unicode,glyphName,orientation,arabicForm,lang) ->+ do gs <- many gContent+ let st hmaps = parseStyles style hmaps+ let sub = SubTree True (id1 ca) (0,0) Nothing Nothing (\maps -> (applyStyleSVG st maps)) (reverse gs)+ return $ GG $ Glyph (id1 ca) sub d (getN horizAdvX) (getN vertOriginX) (getN vertOriginY) (getN vertAdvY)+ unicode glyphName orientation arabicForm lang++getN = maybe 0 (read . T.unpack)++parseHKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+parseHKern = tagName "{http://www.w3.org/2000/svg}hkern" kernAttrs $+ \(ca,u1,g1,u2,g2,k) ->+ do return $ KK $ Kern HKern (charList u1) (charList g1) (charList u2) (charList g2) (getN k)++parseVKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+parseVKern = tagName "{http://www.w3.org/2000/svg}vkern" kernAttrs $+ \(ca,u1,g1,u2,g2,k) ->+ do return $ KK $ Kern VKern (charList u1) (charList g1) (charList u2) (charList g2) (getN k)++charList :: Maybe Text -> [Text]+charList str = maybe [] (T.splitOn ",") str++----------------------------------------------------------------------------------------+-- descriptive elements+------------------------------------------------------o ----------------------------------+-- | Parse \<desc\>, see <http://www.w3.org/TR/SVG/struct.html#DescriptionAndTitleElements>+-- parseDesc :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+parseDesc = tagName "{http://www.w3.org/2000/svg}desc" descAttrs+ $ \(ca,class_,style) ->+ do desc <- content+ return $ Leaf (id1 ca) mempty mempty++-- | Parse \<title\>, see <http://www.w3.org/TR/SVG/struct.html#DescriptionAndTitleElements>+parseTitle = tagName "{http://www.w3.org/2000/svg}title" descAttrs+ $ \(ca,class_,style) ->+ do title <- content+ return $ Leaf (id1 ca) mempty mempty++skipArbitraryTag :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) => Consumer Event m (Maybe (Tag b n))+skipArbitraryTag = do t <- ignoreAnyTreeContent+ if isJust t then return (Just $ Leaf (Just "") mempty mempty)+ else return Nothing++-- | Parse \<meta\>, see <http://www.w3.org/TR/SVG/struct.html#DescriptionAndTitleElements>+--+-- @+-- An example what metadata contains:+--+-- \<metadata+-- id=\"metadata22\"\>+-- \<rdf:RDF\>+-- \<cc:Work+-- rdf:about=\"\"\>+-- \<dc:format\>image\/svg+xml\<\/dc:format\>+-- \<dc:type+-- rdf:resource=\"http:\/\/purl.org\/dc\/dcmitype\/StillImage\" \/\>+-- \</cc:Work\>+-- \</rdf:RDF\>+-- \</metadata\>+-- @+--+{- Maybe we implement it one day++parseMetaData :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseMetaData = tagName "{http://www.w3.org/2000/svg}metadata" ignoreAttrs+ $ \_ ->+ do -- meta <- many metaContent+ return $ Leaf Nothing mempty mempty++-- metaContent :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+metaContent = choose [parseRDF] -- extend if needed++-- parseRDF :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+parseRDF = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}RDF" ignoreAttrs+ $ \_ ->+ do -- c <- parseWork+ return $ Leaf Nothing mempty mempty++-- parseWork :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+parseWork = tagName "{http://creativecommons.org/ns#}Work" ignoreAttrs+ $ \_ ->+ do -- c <- many workContent+ return $ Leaf Nothing mempty mempty++workContent = choose [parseFormat, parseType, parseRDFTitle, parseDate, parseCreator,+ parsePublisher, parseSource, parseLanguage, parseSubject, parseDescription]++parseCreator = tagName "{http://purl.org/dc/elements/1.1/}creator" ignoreAttrs+ $ \_ -> do { c <- parseAgent ; return $ Leaf Nothing mempty mempty }++parseAgent = tagName "{http://creativecommons.org/ns#}Agent" ignoreAttrs+ $ \_ -> do { c <- parseAgentTitle ; return $ Leaf Nothing mempty mempty }++parsePublisher = tagName "{http://purl.org/dc/elements/1.1/}publisher" ignoreAttrs+ $ \_ -> do { c <- parseAgent ; return $ Leaf Nothing mempty mempty }++parseSubject = tagName "{http://purl.org/dc/elements/1.1/}subject" ignoreAttrs+ $ \_ -> do { c <- parseBag ; return $ Leaf Nothing mempty mempty }++-- parseBag :: (MonadThrow m, Metric (V b), Ord (N b), Floating (N b)) => Consumer Event m (Maybe (Tag b n))+parseBag = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}Bag" ignoreAttrs+ $ \_ -> do { c <- parseList ; return $ Leaf Nothing mempty mempty }++parseFormat = tagName "{http://purl.org/dc/elements/1.1/}format" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseType = tagName "{http://purl.org/dc/elements/1.1/}type" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseRDFTitle = tagName "{http://purl.org/dc/elements/1.1/}title" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseDate = tagName "{http://purl.org/dc/elements/1.1/}date" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseAgentTitle = tagName "{http://purl.org/dc/elements/1.1/}title" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseSource = tagName "{http://purl.org/dc/elements/1.1/}source" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseLanguage = tagName "{http://purl.org/dc/elements/1.1/}language" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseList = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}li" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }++parseDescription = tagName "{http://purl.org/dc/elements/1.1/}description" ignoreAttrs+ $ \_ -> do { c <- content ; return $ Leaf Nothing mempty mempty }+-}+------------------------------------+-- inkscape / sodipodi tags+------------------------------------+parseSodipodi = tagName "{http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd}namedview" namedViewAttrs+ $ \(pc,bc,bo,ot,gt,gut,po,ps,ww,wh,id1,sg,zoom,cx,cy,wx,wy,wm,cl) ->+ do -- c <- parseGrid+ return $ Leaf (Just "") mempty mempty++-- <inkscape:grid+-- type="xygrid"+-- id="grid5177" />+parseGrid = tagName "{http://www.inkscape.org/namespaces/inkscape}grid" ignoreAttrs+ $ \_ ->+ do c <- content+ return $ Leaf Nothing mempty mempty++{- <inkscape:perspective+ sodipodi:type="inkscape:persp3d"+ inkscape:vp_x="0 : 212.5 : 1"+ inkscape:vp_y="0 : 1000 : 0"+ inkscape:vp_z="428.75 : 212.5 : 1"+ inkscape:persp3d-origin="214.375 : 141.66667 : 1"+ id="perspective5175" />+-}++parsePerspective = tagName "{http://www.inkscape.org/namespaces/inkscape}perspective" perspectiveAttrs+ $ \(typ,vp_x,vp_y,vp_z,persp3d_origin,id_) ->+ return $ Leaf (Just "") mempty mempty++parsePathEffect = tagName "{http://www.inkscape.org/namespaces/inkscape}path-effect" ignoreAttrs+ $ \_ -> return $ Leaf Nothing mempty mempty+--------------------------------------------------------------------------------------+-- sceletons++-- | Parse \<pattern\>, see <http://www.w3.org/TR/SVG/pservers.html#PatternElement>+parsePattern :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parsePattern = tagName "{http://www.w3.org/2000/svg}pattern" patternAttrs $+ \(cpa,ca,pa,class_,style,ext,view,ar,x,y,w,h,pUnits,pCUnits,pTrans) ->+ do c <- content -- insidePattern <- many patternContent+ return $ Leaf (Just "") mempty mempty++patternContent :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+patternContent = choose [parseImage]++-- | Parse \<filter\>, see <http://www.w3.org/TR/SVG/filters.html#FilterElement>+parseFilter = tagName "{http://www.w3.org/2000/svg}filter" filterAttrs $+ \(ca,pa,xlink,class_,style,ext,x,y,w,h,filterRes,filterUnits,primUnits) ->+ do -- insideFilter <- many filterContent+ return $ Leaf (id1 ca) mempty mempty++filterContent = choose [ parseFeGaussianBlur,+ parseFeBlend,parseFeColorMatrix,parseFeComponentTransfer,parseFeComposite,parseFeConvolveMatrix, -- filter primitive elments+ parseFeDiffuseLighting,parseFeDisplacementMap,parseFeFlood,parseFeImage,+ parseFeMerge,parseFeMorphology,parseFeOffset,parseFeSpecularLighting,parseFeTile,parseFeTurbulence,+ parseDesc,parseTitle]++--------------------------------------------------------------------------------------+-- filter primitives (currently only sceletons)+--------------------------------------------------------------------------------------++-- | Parse \<feBlend\>, see <http://www.w3.org/TR/SVG/filters.html#feBlendElement>+parseFeBlend = tagName "{http://www.w3.org/2000/svg}feBlend" feBlendAttrs $+ \(ca,pa,fpa,class_,style,in1,in2,mode) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feColorMatrix\>, see <http://www.w3.org/TR/SVG/filters.html#feColorMatrixElement>+parseFeColorMatrix = tagName "{http://www.w3.org/2000/svg}feColorMatrix" feColorMatrixAttrs $+ \(ca,pa,fpa,class_,style,in1,type1,values) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feComponentTransfer\>, see <http://www.w3.org/TR/SVG/filters.html#feComponentTransferElement>+parseFeComponentTransfer = tagName "{http://www.w3.org/2000/svg}feComponentTransfer" feComponentTransferAttrs $+ \(ca,pa,fpa,class_,style,in1) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feComposite\>, see <http://www.w3.org/TR/SVG/filters.html#feCompositeElement>+parseFeComposite = tagName "{http://www.w3.org/2000/svg}feComposite" feCompositeAttrs $+ \(ca,pa,fpa,class_,style,in1,in2,operator,k1,k2,k3,k4) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feConvolveMatrix\>, see <http://www.w3.org/TR/SVG/filters.html#feConvolveMatrixElement>+parseFeConvolveMatrix = tagName "{http://www.w3.org/2000/svg}feConvolveMatrix" feConvolveMatrixAttrs $+ \(ca,pa,fpa,class_,style,order,km,d,bias,tx,ty,em,ku,par) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feDiffuseLighting\>, see <http://www.w3.org/TR/SVG/filters.html#feDiffuseLightingElement>+parseFeDiffuseLighting = tagName "{http://www.w3.org/2000/svg}feDiffuseLighting" feDiffuseLightingAttrs $+ \(ca,pa,fpa,class_,style,in1,surfaceScale,diffuseConstant,kuLength) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feDisplacementMap\>, see <http://www.w3.org/TR/SVG/filters.html#feDisplacementMapElement>+parseFeDisplacementMap = tagName "{http://www.w3.org/2000/svg}feDisplacementMap" feDisplacementMapAttrs $+ \(ca,pa,fpa,class_,style,in1,in2,sc,xChan,yChan) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feFlood\>, see <http://www.w3.org/TR/SVG/filters.html#feFloodElement>+parseFeFlood = tagName "{http://www.w3.org/2000/svg}feFlood" feFloodAttrs $+ \(ca,pa,fpa,class_,style) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feGaussianBlur\>, see <http://www.w3.org/TR/SVG/filters.html#feGaussianBlurElement>+parseFeGaussianBlur = tagName "{http://www.w3.org/2000/svg}feGaussianBlur" feGaussianBlurAttrs $+ \(ca,pa,fpa,class_,style,in1,stdDeviation) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feImage\>, see <http://www.w3.org/TR/SVG/filters.html#feImageElement>+parseFeImage = tagName "{http://www.w3.org/2000/svg}feImage" feImageAttrs $+ \(ca,pa,fpa,xlibk,class_,style,ext,par) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feMerge\>, see <http://www.w3.org/TR/SVG/filters.html#feMergeElement>+parseFeMerge = tagName "{http://www.w3.org/2000/svg}feMerge" feMergeAttrs $+ \(ca,pa,fpa,class_,style) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feMorphology\>, see <http://www.w3.org/TR/SVG/filters.html#feMorphologyElement>+parseFeMorphology = tagName "{http://www.w3.org/2000/svg}feMorphology" feMorphologyAttrs $+ \(ca,pa,fpa,class_,style,in1,operator,radius) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feOffset\>, see <http://www.w3.org/TR/SVG/filters.html#feOffsetElement>+parseFeOffset = tagName "{http://www.w3.org/2000/svg}feOffset" feOffsetAttrs $+ \(ca,pa,fpa,class_,style,in1,dx,dy) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feSpecularLighting\>, see <http://www.w3.org/TR/SVG/filters.html#feSpecularLightingElement>+parseFeSpecularLighting = tagName "{http://www.w3.org/2000/svg}feSpecularLighting" feSpecularLightingAttrs $+ \(ca,pa,fpa,class_,style,in1,surfaceScale,sc,se,ku) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feTile\>, see <http://www.w3.org/TR/SVG/filters.html#feTileElement>+parseFeTile = tagName "{http://www.w3.org/2000/svg}feTile" feTileAttrs $+ \(ca,pa,fpa,class_,style,in1) -> return $ Leaf (id1 ca) mempty mempty++-- | Parse \<feTurbulence\>, see <http://www.w3.org/TR/SVG/filters.html#feTurbulenceElement>+parseFeTurbulence = tagName "{http://www.w3.org/2000/svg}feTurbulence" feTurbulenceAttrs $+ \(ca,pa,fpa,class_,style,in1,in2,mode) -> return $ Leaf (id1 ca) mempty mempty++------------------------------------------------------------------------------------++animationElements = []
+ src/Diagrams/SVG/Tree.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleContexts #-}+--------------------------------------------------------------------+-- |+-- Module : Diagrams.SVG.Tree+-- Copyright : (c) 2015 Tillmann Vogt <tillk.vogt@googlemail.com>+-- License : BSD3+--+-- Maintainer: diagrams-discuss@googlegroups.com+-- Stability : stable+-- Portability: portable++module Diagrams.SVG.Tree+ (+ -- * Tree data type+ Tag(..)+ , HashMaps(..)+ -- * Extract data from the tree+ , nodes+ , Attrs(..)+ , NodesMap+ , CSSMap+ , GradientsMap+ , PreserveAR(..)+ , AlignSVG(..)+ , MeetOrSlice(..)+ , Place+ , ViewBox(..)+ , Gr(..)+ , GradientAttributes(..)+ , PresentationAttributes(..)+ , GradRefId+ , expandGradMap+ , insertRefs+ , preserveAspectRatio+ , FontContent(..)+ , FontData(..)+ , FontFace(..)+ , Glyph(..)+ , KernDir(..)+ , KernMaps(..)+ , SvgGlyphs(..)+ , Kern(..)+ )+where+import Data.Maybe (isJust, fromJust , fromMaybe)+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import Data.Text(Text(..))+import Data.Vector(Vector)+import Diagrams.Prelude hiding (Vector)+import Diagrams.TwoD.Size+-- import Diagrams.SVG.Fonts.ReadFont+import Debug.Trace++-- Note: Maybe we could use the Tree from diagrams here but on the other hand this makes diagrams-input +-- more independent of changes of diagrams' internal structures++-------------------------------------------------------------------------------------+-- | A tree structure is needed to handle refences to parts of the tree itself.+-- The \<defs\>-section contains shapes that can be refered to, but the SVG standard allows to refer to+-- every tag in the SVG-file.+--+data Tag b n = Leaf Id (ViewBox n -> Path V2 n) ((HashMaps b n, ViewBox n) -> Diagram b)-- ^+-- A leaf consists of+--+-- * An Id+--+-- * A path so that this leaf can be used to clip some other part of a tree+--+-- * A diagram (Another option would have been to apply a function to the upper path)+ | Reference Id Id (ViewBox n -> Path V2 n) ((HashMaps b n, ViewBox n) -> Diagram b -> Diagram b)-- ^+-- A reference (\<use\>-tag) consists of:+--+-- * An Id+--+-- * A reference to an Id+--+-- * A viewbox so that percentages are relative to this viewbox+--+-- * Transformations applied to the reference+ | SubTree Bool Id (Double, Double)+ (Maybe (ViewBox n)) + (Maybe PreserveAR) + (HashMaps b n -> Diagram b -> Diagram b) + [Tag b n]-- ^+-- A subtree consists of:+--+-- * A Bool: Are we in a section that will be rendered directly (not in a \<defs\>-section)+--+-- * An Id of subdiagram+--+-- * A viewbox so that percentages are relative to this viewbox+--+-- * Aspect Ratio+--+-- * A transformation or application of a style to a subdiagram+--+-- * A list of subtrees+ | StyleTag [(Text, [(Text, Text)])] -- ^ A tag that contains CSS styles with selectors and attributes+ | FontTag (FontData b n)+ | Grad Id (Gr n) -- ^ A gradient+ | Stop (HashMaps b n -> [GradientStop n]) -- ^+-- We need to make this part of this data structure because Gradient tags can also contain description tags++type Id = Maybe Text+type GradRefId = Maybe Text+type Attrs = [(Text, Text)]++type Nodelist b n = [(Text, Tag b n)]+type CSSlist = [(Text, Attrs)]+data Gr n = Gr GradRefId+ GradientAttributes+ (Maybe (ViewBox n))+ [CSSMap -> [GradientStop n]]+ (CSSMap -> GradientAttributes -> ViewBox n -> [CSSMap -> [GradientStop n]] -> Texture n)++type Gradlist n = [(Text, Gr n)]+type Fontlist b n = [(Text, FontData b n)]++type HashMaps b n = (NodesMap b n, CSSMap, GradientsMap n)+type NodesMap b n = H.HashMap Text (Tag b n)+type CSSMap = H.HashMap Text Attrs+type GradientsMap n = H.HashMap Text (Gr n)++type ViewBox n = (n,n,n,n) -- (MinX,MinY,Width,Height)++data PreserveAR = PAR AlignSVG MeetOrSlice -- ^ see <http://www.w3.org/TR/SVG11/coords.html#PreserveAspectRatioAttribute>+data AlignSVG = AlignXY Place Place -- ^ alignment in x and y direction+type Place = Double -- ^ A value between 0 and 1, where 0 is the minimal value and 1 the maximal value+data MeetOrSlice = Meet | Slice++instance Show (Tag b n) where+ show (Leaf id1 _ _) = "Leaf " ++ (show id1) ++ "\n"+ show (Reference selfid id1 viewbox f) = "Reference " ++ (show id1) ++ "\n"+ show (SubTree b id1 wh viewbox ar f tree) = "Sub " ++ (show id1) ++ concat (map show tree) ++ "\n"+ show (StyleTag _) = "Style " ++ "\n"+ show (Grad id1 gr) = "Grad id:" ++ (show id1) -- ++ (show gr) ++ "\n"+ show (Stop _) = "Stop " ++ "\n"++-- instance Show (Gr n) where show (Gr gradRefId gattr vb stops tex) = " ref:" ++ (show gradRefId) ++ "viewbox: " ++ (show vb)++----------------------------------------------------------------------------------+-- | Generate elements that can be referenced by their ID.+-- The tree nodes are splitted into 4 groups of lists of (ID,value)-pairs):+--+-- * Nodes that contain elements that can be transformed to a diagram+--+-- * CSS classes with corresponding (attribute,value)-pairs, from the <defs>-tag+--+-- * Gradients+--+-- * Fonts+nodes :: Maybe (ViewBox n) -> (Nodelist b n, CSSlist, Gradlist n, Fontlist b n) -> Tag b n -> + (Nodelist b n, CSSlist, Gradlist n, Fontlist b n)+nodes viewbox (ns,css,grads,fonts) (Leaf id1 path diagram)+ | isJust id1 = (ns ++ [(fromJust id1, Leaf id1 path diagram)],css,grads,fonts)+ | otherwise = (ns,css,grads,fonts)++-- A Reference element for the <use>-tag+nodes viewbox (ns,css,grads,fonts) (Reference selfId id1 vb f) = (ns,css,grads,fonts)++nodes viewbox (ns,css,grads,fonts) (SubTree b id1 wh Nothing ar f children)+ | isJust id1 = myconcat [ (ns ++ [(fromJust id1, SubTree b id1 wh viewbox ar f children)],css,grads,fonts) ,+ (myconcat (map (nodes viewbox (ns,css,grads,fonts)) children)) ]+ | otherwise = myconcat (map (nodes viewbox (ns,css,grads,fonts)) children)++nodes viewbox (ns,css,grads,fonts) (SubTree b id1 wh vb ar f children)+ | isJust id1 = myconcat [ (ns ++ [(fromJust id1, SubTree b id1 wh vb ar f children)],css,grads,fonts) ,+ (myconcat (map (nodes vb (ns,css,grads,fonts)) children)) ]+ | otherwise = myconcat (map (nodes vb (ns,css,grads,fonts)) children)++nodes viewbox (ns,css,grads,fonts) (Grad id1 (Gr gradRefId gattr vb stops texture))+ | isJust id1 = (ns,css, grads ++ [(fromJust id1, Gr gradRefId gattr vb stops texture)], fonts)+ | otherwise = (ns,css,grads,fonts)++-- There is a global style tag in the defs section of some svg files+nodes viewbox (ns,css,grads,fonts) (StyleTag styles) = (ns,css ++ styles,grads,fonts)+-- stops are not extracted here but from the gradient parent node+nodes viewbox lists (Stop _) = lists++nodes viewbox (ns,css,grads,fonts) (FontTag fontData) = (ns,css,grads,fonts ++ [(fromMaybe "" (fontId fontData), fontData)])++myconcat :: [(Nodelist b n, CSSlist, Gradlist n, Fontlist b n)] -> (Nodelist b n, CSSlist, Gradlist n, Fontlist b n)+myconcat list = (concat $ map sel1 list, concat $ map sel2 list, concat $ map sel3 list, concat $ map sel4 list)+ where sel1 (a,b,c,d) = a+ sel2 (a,b,c,d) = b+ sel3 (a,b,c,d) = c+ sel4 (a,b,c,d) = d++------------------------------------------------------------------------------------------------------+-- The following code is necessary to handle nested xlink:href in gradients,+-- like in this example (#linearGradient3606 in radialGradient):+--+-- <linearGradient+-- id="linearGradient3606">+-- <stop+-- id="stop3608"+-- style="stop-color:#ff633e;stop-opacity:1"+-- offset="0" />+-- <stop+-- id="stop3610"+-- style="stop-color:#ff8346;stop-opacity:0.78225809"+-- offset="1" />+-- </linearGradient>+-- <radialGradient+-- cx="275.00681"+-- cy="685.96008"+-- r="112.80442"+-- fx="275.00681"+-- fy="685.96008"+-- id="radialGradient3612"+-- xlink:href="#linearGradient3606"+-- gradientUnits="userSpaceOnUse"+-- gradientTransform="matrix(1,0,0,1.049029,-63.38387,-67.864647)" />++-- | Gradients contain references to include attributes/stops from other gradients. +-- expandGradMap expands the gradient with these attributes and stops++expandGradMap :: GradientsMap n -> GradientsMap n -- GradientsMap n = H.HashMap Text (Gr n)+expandGradMap gradMap = H.mapWithKey (newGr gradMap) gradMap++newGr grMap key (Gr gradRefId attrs vb stops f) = (Gr gradRefId newAttributes vb newStops f)+ where newStops = stops ++ (gradientStops grMap gradRefId)+ newAttributes = overwriteDefaultAttributes $ gradientAttributes grMap (Just key)++-- | Gradients that reference other gradients form a list of attributes+-- The last element of this list are the default attributes (thats why there is "reverse attrs")+-- Then the second last attributes overwrite these defaults (and so on until the root)+-- The whole idea of this nesting is that Nothing values don't overwrite Just values+overwriteDefaultAttributes :: [GradientAttributes] -> GradientAttributes+overwriteDefaultAttributes [attrs] = attrs+overwriteDefaultAttributes attrs = foldl1 updateRec (reverse attrs)++-- | Every reference is looked up in the gradient map and a record of attributes is added to a list+gradientAttributes :: GradientsMap n -> GradRefId -> [GradientAttributes] -- GradientsMap n = H.HashMap Text (Gr n)+gradientAttributes grMap Nothing = []+gradientAttributes grMap (Just refId) | isJust gr = (attrs $ fromJust gr) : (gradientAttributes grMap (grRef $ fromJust gr))+ | otherwise = []+ where gr = H.lookup refId grMap+ grRef (Gr ref _ _ _ _) = ref++attrs (Gr _ att _ _ _) = att++-- | Every reference is looked up in the gradient map and the stops are added to a list+gradientStops :: GradientsMap n -> GradRefId -> [CSSMap -> [GradientStop n]]+gradientStops grMap Nothing = []+gradientStops grMap (Just refId) | isJust gr = (stops $ fromJust gr) ++ (gradientStops grMap (grRef $ fromJust gr))+ | otherwise = []+ where gr = H.lookup refId grMap+ grRef (Gr ref _ _ _ _) = ref+ stops (Gr _ _ _ st _) = st++-- | Update the gradient record. The first argument is the leaf record, the second is the record that overwrites the leaf.+-- The upper example references gradients that have only stops (no overwriting of attributes).+-- See <http://www.w3.org/TR/SVG/pservers.html#RadialGradientElementHrefAttribute>+updateRec :: GradientAttributes -> GradientAttributes -> GradientAttributes+updateRec (GA pa class_ style x1 y1 x2 y2 cx cy r fx fy gradientUnits gradientTransform spreadMethod)+ (GA paN class1N styleN x1N y1N x2N y2N cxN cyN rN fxN fyN gradientUnitsN gradientTransformN spreadMethodN)+ = toGA (paN, (updateList [class_,style,x1,y1,x2,y2,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod] -- TODO: update pa+ [class1N,styleN,x1N,y1N,x2N,y2N,cxN,cyN,rN,fxN,fyN,gradientUnitsN,gradientTransformN,spreadMethodN]))+ where+ updateList :: [Maybe Text] -> [Maybe Text] -> [Maybe Text]+ updateList (defaultt:xs) ((Just t1):ys) = (Just t1) : (updateList xs ys)+ updateList ((Just t0):xs) (Nothing :ys) = (Just t0) : (updateList xs ys)+ updateList (Nothing :xs) (Nothing :ys) = Nothing : (updateList xs ys)+ updateList _ _ = []++ toGA (pa, [class_,style,x1,y1,x2,y2,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod]) =+ GA pa class_ style x1 y1 x2 y2 cx cy r fx fy gradientUnits gradientTransform spreadMethod++------------------------------------------------------------------------------------------------------------++-- | Lookup a diagram and return an empty diagram in case the SVG-file has a wrong reference+lookUp hmap i | (isJust i) && (isJust l) = fromJust l+ | otherwise = Leaf Nothing mempty mempty -- an empty diagram if we can't find the id+ where l = H.lookup (fromJust i) hmap++-- | Evaluate the tree into a diagram by inserting xlink:href references from nodes and gradients, +-- applying clipping and passing the viewbox to the leafs+insertRefs :: (V b ~ V2, N b ~ n, RealFloat n, Place ~ n) => (HashMaps b n, ViewBox n) -> Tag b n -> Diagram b++insertRefs (maps,viewbox) (Leaf id1 path f) = (f (maps,viewbox)) # (if isJust id1 then named (T.unpack $ fromJust id1) else id)+insertRefs (maps,viewbox) (Grad _ _) = mempty+insertRefs (maps,viewbox) (Stop f) = mempty+insertRefs (maps,viewbox) (Reference selfId id1 path styles)+ | (Diagrams.TwoD.Size.width r) <= 0 || (Diagrams.TwoD.Size.height r) <= 0 = mempty+ | otherwise = referencedDiagram # styles (maps,viewbox)+ # cutOutViewBox viewboxPAR+-- # stretchViewBox (fromJust w) (fromJust h) viewboxPAR+ # (if isJust selfId then named (T.unpack $ fromJust selfId) else id)+ where r = path viewbox+ viewboxPAR = getViewboxPreserveAR subTree+ referencedDiagram = insertRefs (maps,viewbox) (makeSubTreeVisible viewbox subTree)+ subTree = lookUp (sel1 maps) id1+ getViewboxPreserveAR (SubTree _ id1 wh viewbox ar g children) = (viewbox, ar)+ getViewboxPreserveAR _ = (Nothing, Nothing)+ sel1 (a,b,c) = a++insertRefs (maps,viewbox) (SubTree False _ _ _ _ _ _) = mempty+insertRefs (maps,viewbox) (SubTree True id1 (w,h) viewb ar styles children) =+ subdiagram # styles maps+ # cutOutViewBox (viewb, ar)+ # (if (w > 0) && (h > 0) then stretchViewBox w h (viewb, ar) else id)+ # (if isJust id1 then named (T.unpack $ fromJust id1) else id)+ where subdiagram = mconcat (map (insertRefs (maps, fromMaybe viewbox viewb)) children)++insertRefs (maps,viewbox) (StyleTag _) = mempty+-------------------------------------------------------------------------------------------------------------------------------++makeSubTreeVisible viewbox (SubTree _ id1 wh vb ar g children) =+ (SubTree True id1 wh (Just viewbox) ar g (map (makeSubTreeVisible viewbox) children))+makeSubTreeVisible _ x = x++stretchViewBox w h ((Just (minX,minY,width,height), Just par)) = preserveAspectRatio w h (width - minX) (height - minY) par+stretchViewBox w h ((Just (minX,minY,width,height), Nothing)) = -- Debug.Trace.trace "nothing" $+ preserveAspectRatio w h (width - minX) (height - minY) (PAR (AlignXY 0.5 0.5) Meet)+stretchViewBox w h _ = id++cutOutViewBox (Just (minX,minY,width,height), _) = rectEnvelope (p2 (minX, minY)) (r2 ((width - minX), (height - minY)))+ -- (clipBy (rect (width - minX) (height - minY)))+cutOutViewBox _ = id++-------------------------------------------------------------------------------------------------------------------------------+-- | preserveAspectRatio is needed to fit an image into a frame that has a different aspect ratio than the image+-- (e.g. 16:10 against 4:3).+-- SVG embeds images the same way: <http://www.w3.org/TR/SVG11/coords.html#PreserveAspectRatioAttribute>+--+-- > import Graphics.SVGFonts+-- >+-- > portrait preserveAR width height = stroke (readSVGFile preserveAR width height "portrait.svg") # showOrigin+-- > text' t = stroke (textSVG' $ TextOpts t lin INSIDE_H KERN False 1 1 ) # fc back # lc black # fillRule EvenOdd+-- > portraitMeet1 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Meet") ===+-- > (portrait (PAR (AlignXY x y) Meet) 200 100 <> rect 200 100)+-- > portraitMeet2 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Meet") ===+-- > (portrait (PAR (AlignXY x y) Meet) 100 200 <> rect 100 200)+-- > portraitSlice1 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Slice") ===+-- > (portrait (PAR (AlignXY x y) Slice) 100 200 <> rect 100 200)+-- > portraitSlice2 x y = (text' "PAR (AlignXY " ++ show x ++ " " show y ++ ") Slice") ===+-- > (portrait (PAR (AlignXY x y) Slice) 200 100 <> rect 200 100)+-- > meetX = (text' "meet") === (portraitMeet1 0 0 ||| portraitMeet1 0.5 0 ||| portraitMeet1 1 0)+-- > meetY = (text' "meet") === (portraitMeet2 0 0 ||| portraitMeet2 0 0.5 ||| portraitMeet2 0 1)+-- > sliceX = (text' "slice") === (portraitSlice1 0 0 ||| portraitSlice1 0.5 0 ||| portraitSlice1 1 0)+-- > sliceY = (text' "slice") === (portraitSlice2 0 0 ||| portraitSlice2 0 0.5 ||| portraitSlice2 0 1)+-- > im = (text' "Image to fit") === (portrait (PAR (AlignXY 0 0) Meet) 123 456)+-- > viewport1 = (text' "Viewport1") === (rect 200 100)+-- > viewport2 = (text' "Viewport2") === (rect 100 200)+-- > imageAndViewports = im === viewport1 === viewport2+-- >+-- > par = imageAndViewports ||| ( ( meetX ||| meetY) === ( sliceX ||| sliceY) )+--+-- <<diagrams/src_Graphics_SVGFonts_ReadFont_textPic0.svg#diagram=par&width=300>>+-- preserveAspectRatio :: Width -> Height -> Width -> Height -> PreserveAR -> Diagram b -> Diagram b+preserveAspectRatio newWidth newHeight oldWidth oldHeight preserveAR image+ | aspectRatio < newAspectRatio = xPlace preserveAR image+ | otherwise = yPlace preserveAR image+ where aspectRatio = oldWidth / oldHeight+ newAspectRatio = newWidth / newHeight+ scaX = newHeight / oldHeight+ scaY = newWidth / oldWidth+ xPlace (PAR (AlignXY x y) Meet) i = i # scale scaX # alignBL # translateX ((newWidth - oldWidth*scaX)*x)+ xPlace (PAR (AlignXY x y) Slice) i = i # scale scaY # alignBL # translateX ((newWidth - oldWidth*scaX)*x)+-- # view (p2 (0, 0)) (r2 (newWidth, newHeight))++ yPlace (PAR (AlignXY x y) Meet) i = i # scale scaY # alignBL # translateY ((newHeight - oldHeight*scaY)*y)+ yPlace (PAR (AlignXY x y) Slice) i = i # scale scaX # alignBL # translateY ((newHeight - oldHeight*scaY)*y)+-- # view (p2 (0, 0)) (r2 (newWidth, newHeight))+++-- a combination of linear- and radial-attributes so that referenced gradients can replace Nothing-attributes+data GradientAttributes =+ GA { presentationAttributes :: PresentationAttributes+ , class_ :: Maybe Text+ , style :: Maybe Text+ , x1 :: Maybe Text+ , y1 :: Maybe Text+ , x2 :: Maybe Text+ , y2 :: Maybe Text+ , cx :: Maybe Text+ , cy :: Maybe Text+ , r :: Maybe Text+ , fx :: Maybe Text+ , fy :: Maybe Text+ , gradientUnits :: Maybe Text+ , gradientTransform :: Maybe Text+ , spreadMethod :: Maybe Text+ }++-- GA pa class_ style x1 y1 x2 y2 cx cy r fx fy gradientUnits gradientTransform spreadMethod++data PresentationAttributes =+ PA { alignmentBaseline :: Maybe Text+ , baselineShift :: Maybe Text+ , clip :: Maybe Text+ , clipPath :: Maybe Text+ , clipRule :: Maybe Text+ , color :: Maybe Text+ , colorInterpolation :: Maybe Text+ , colorInterpolationFilters :: Maybe Text+ , colorProfile :: Maybe Text+ , colorRendering :: Maybe Text+ , cursor :: Maybe Text+ , direction :: Maybe Text+ , display :: Maybe Text+ , dominantBaseline :: Maybe Text+ , enableBackground :: Maybe Text+ , fill :: Maybe Text+ , fillOpacity :: Maybe Text+ , fillRuleSVG :: Maybe Text+ , filter :: Maybe Text+ , floodColor :: Maybe Text+ , floodOpacity :: Maybe Text+ , fontFamily :: Maybe Text+ , fntSize :: Maybe Text+ , fontSizeAdjust :: Maybe Text+ , fontStretch :: Maybe Text+ , fontStyle :: Maybe Text+ , fontVariant :: Maybe Text+ , fontWeight :: Maybe Text+ , glyphOrientationHorizontal :: Maybe Text+ , glyphOrientationVertical :: Maybe Text+ , imageRendering :: Maybe Text+ , kerning :: Maybe Text+ , letterSpacing :: Maybe Text+ , lightingColor :: Maybe Text+ , markerEnd :: Maybe Text+ , markerMid :: Maybe Text+ , markerStart :: Maybe Text+ , mask :: Maybe Text+ , opacity :: Maybe Text+ , overflow :: Maybe Text+ , pointerEvents :: Maybe Text+ , shapeRendering :: Maybe Text+ , stopColor :: Maybe Text+ , stopOpacity :: Maybe Text+ , strokeSVG :: Maybe Text+ , strokeDasharray :: Maybe Text+ , strokeDashoffset :: Maybe Text+ , strokeLinecap :: Maybe Text+ , strokeLinejoin :: Maybe Text+ , strokeMiterlimit :: Maybe Text+ , strokeOpacity :: Maybe Text+ , strokeWidth :: Maybe Text+ , textAnchor :: Maybe Text+ , textDecoration :: Maybe Text+ , textRendering :: Maybe Text+ , unicodeBidi :: Maybe Text+ , visibility :: Maybe Text+ , wordSpacing :: Maybe Text+ , writingMode :: Maybe Text+ } deriving Show++type SvgGlyphs n = H.HashMap Text (Maybe Text, n, Maybe Text)+-- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \]++data Kern n = Kern+ { kernDir :: KernDir+ , kernU1 :: [Text]+ , kernU2 :: [Text]+ , kernG1 :: [Text]+ , kernG2 :: [Text]+ , kernK :: n+ }++-- | Data from the subtags+data FontContent b n = FF (FontFace n) | GG (Glyph b n) | KK (Kern n)++-- | All data in the \<font\>-tag+data FontData b n = FontData+ {+ fontId :: Maybe Text+ , fontDataHorizontalOriginX :: Maybe Text+ , fontDataHorizontalOriginY :: Maybe Text+ , fontDataHorizontalAdvance :: n+ , fontDataVerticalOriginX :: Maybe Text+ , fontDataVerticalOriginY :: Maybe Text+ , fontDataVerticalAdvance :: Maybe Text+ -- ^ data gathered from subtags+ , fontFace :: FontFace n+ , fontMissingGlyph :: Glyph b n+ , fontDataGlyphs :: SvgGlyphs n+-- , fontDataRawKernings :: [(Text, [Text], [Text], [Text], [Text])]+ , fontDataKerning :: KernMaps n+-- , fontDataFileName :: Text+}++data FontFace n = FontFace+ { fontDataFamily :: Maybe Text+ , fontDataStyle :: Maybe Text+ , fontDataVariant :: Maybe Text+ , fontDataWeight :: Maybe Text+ , fontDataStretch :: Maybe Text+ , fontDataSize :: Maybe Text+ , fontDataUnicodeRange :: Maybe Text+ , fontDataUnitsPerEm :: Maybe Text+ , fontDataPanose :: Maybe Text+ , fontDataVerticalStem :: Maybe Text+ , fontDataHorizontalStem :: Maybe Text+ , fontDataSlope :: Maybe Text+ , fontDataCapHeight :: Maybe Text+ , fontDataXHeight :: Maybe Text+ , fontDataAccentHeight :: Maybe Text+ , fontDataAscent :: Maybe Text+ , fontDataDescent :: Maybe Text+ , fontDataWidths :: Maybe Text+ , fontDataBoundingBox :: [n]+ , fontDataIdeographicBaseline :: Maybe Text+ , fontDataAlphabeticBaseline :: Maybe Text+ , fontDataMathematicalBaseline :: Maybe Text+ , fontDataHangingBaseline :: Maybe Text+ , fontDataVIdeographicBaseline :: Maybe Text+ , fontDataVAlphabeticBaseline :: Maybe Text+ , fontDataVMathematicalBaseline :: Maybe Text+ , fontDataVHangingBaseline :: Maybe Text+ , fontDataUnderlinePos :: Maybe Text+ , fontDataUnderlineThickness :: Maybe Text+ , fontDataStrikethroughPos :: Maybe Text+ , fontDataStrikethroughThickness :: Maybe Text+ , fontDataOverlinePos :: Maybe Text+ , fontDataOverlineThickness :: Maybe Text+ }++data Glyph b n = Glyph+ { glyphId :: Maybe Text+ , glyph :: Tag b n+ , d :: Maybe Text+ , horizAdvX :: n+ , vertOriginX :: n+ , vertOriginY :: n+ , vertAdvY :: n+ , unicode :: Maybe Text+ , glyphName :: Maybe Text+ , orientation :: Maybe Text+ , arabicForm :: Maybe Text+ , lang :: Maybe Text+ }++data KernDir = HKern | VKern++data KernMaps n = KernMaps+ { kernDirs :: [KernDir]+ , kernU1S :: H.HashMap Text [Int]+ , kernU2S :: H.HashMap Text [Int]+ , kernG1S :: H.HashMap Text [Int]+ , kernG2S :: H.HashMap Text [Int]+ , kernKs :: Vector n+ }+
+ src/Diagrams/TwoD/Input.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.TwoD.Input+-- Copyright : (c) 2015 Tillmann Vogt+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Importing external images into diagrams.+-----------------------------------------------------------------------------++module Diagrams.TwoD.Input+ ( loadImageEmbedded+ , loadImageExternal+ ) where++import Control.Monad (msum)+import Codec.Picture+import Codec.Picture.Types (dynamicMap)++import Data.Semigroup+import Data.Typeable (Typeable)++import Diagrams.Core+import Diagrams.TwoD.Image+import Diagrams.TwoD.Size+import Diagrams.TwoD.Types+import qualified Diagrams.TwoD.Text as TT+import Diagrams.SVG.ReadSVG (readSVGFile, InputConstraints)+import Diagrams.SVG.Tree (Place)+import Filesystem.Path.CurrentOS (decodeString)++-- | Load 2d formats given by a filepath and embed them+loadImageEmbedded :: (InputConstraints b n, Renderable (TT.Text n) b, Read n, n ~ Place) + => String -> IO (Either String (QDiagram b V2 n Any))+loadImageEmbedded path = do+ dImg <- readImage path+ svgImg <- readSVGFile (decodeString path)+ return $ msum [ svgImg,+ fmap (image.rasterImage) dImg ] -- skip "Left"s and use the first "Right" image+ where+ rasterImage img = DImage (ImageRaster img) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty++-- | Load 2d formats given by a filepath and make a reference+loadImageExternal :: (InputConstraints b n, Renderable (DImage n External) b) + => FilePath -> IO (Either String (QDiagram b V2 n Any))+loadImageExternal path = do+ dImg <- readImage path+-- svgImg <- readSVGFile path+ return $ msum [ fmap (image.rasterPath) dImg ]+-- svgImg ] -- skip "Left"s and use the first "Right" image+ where+ rasterPath img = DImage (ImageRef path) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty+