svg-tree 0.6 → 0.6.1

raw patch · 4 files changed

+2998/−2976 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +70/−64
• src/Graphics/Svg/Types.hs +1631/−1624
• src/Graphics/Svg/XmlParser.hs +1236/−1227
• svg-tree.cabal +61/−61

@@ -1,64 +1,70 @@--*-change-log-*---v0.6: September 2016- * Add SVG 2.0 gradient mesh- * Add gradient opacity parsing--v0.5.1.2: September 2016- * Fix path parsing with white space prefix--v0.5.1.1: May 2016- * Fix: GHC 8.0 compatibility--v0.5.1: March 2016- * Fix: serialization of multi criteria css selector.--v0.5: March 2016:- * Adding: preserveAspectRatio attribute- * Fix: Application of CSS rules with indirect parent/child relation.--v0.4.2: March 2016- * Enhancement: avoiding serializatinon of empty class attribute- * Fix: incorrect deserialization of complex CSS- * Fix: Really fixing duplicate ID with serialization--v0.4.1: February 2016- * Fix: fixing duplicate ID with serialization--v0.4: February 2016- * Breaking change: viewbox types are no longer Int-   but double, sneakingly passed in v0.3.2.2. This-   version acknoweledge this change--V0.3.2.2 February 2016 (Deprecated)- * Fix: Bad serialization of some None constructors.--v0.3.2.1 October 2015- * Fix: Don't add '#' for <img> serialization--v0.3.2 August 2015- * Fix: allow compilation with GHC 7.4--v0.3.1 May 2015- * Fix: Bumping lens dependency and removing upper bound.--v0.3 April 2015- * Breaking change: Switching all the numeric types associated to geometry-   to Double precision (thx to Kasbah)--v0.2 April 2015- * Fix: Differentiating opacity & fill-opacity, as they are-   semantically deferent (BREAKING CHANGE!)--v0.1.1 April 2015- * Fix: Bumping lens bounds--v0.1.0.2 March 2015- * Fix: Bumping lens bounds--v0.1.0.1- * Fix: Lowering some lower bounds--v0.1- * Initial release-+-*-change-log-*-
+
+v0.6.1: January 2017
+ * Fix: some gradient mesh parsing, stop can have style (like with Inkscape 0.92)
+ * Fix: norm say "<mesh>" is the global tag
+ * Fix: Adding `xlink:href` attribute on patterns
+ * Fix: Adding `patternTransform` attribute on patterns
+
+v0.6: September 2016
+ * Add SVG 2.0 gradient mesh
+ * Add gradient opacity parsing
+
+v0.5.1.2: September 2016
+ * Fix path parsing with white space prefix
+
+v0.5.1.1: May 2016
+ * Fix: GHC 8.0 compatibility
+
+v0.5.1: March 2016
+ * Fix: serialization of multi criteria css selector.
+
+v0.5: March 2016:
+ * Adding: preserveAspectRatio attribute
+ * Fix: Application of CSS rules with indirect parent/child relation.
+
+v0.4.2: March 2016
+ * Enhancement: avoiding serializatinon of empty class attribute
+ * Fix: incorrect deserialization of complex CSS
+ * Fix: Really fixing duplicate ID with serialization
+
+v0.4.1: February 2016
+ * Fix: fixing duplicate ID with serialization
+
+v0.4: February 2016
+ * Breaking change: viewbox types are no longer Int
+   but double, sneakingly passed in v0.3.2.2. This
+   version acknoweledge this change
+
+V0.3.2.2 February 2016 (Deprecated)
+ * Fix: Bad serialization of some None constructors.
+
+v0.3.2.1 October 2015
+ * Fix: Don't add '#' for <img> serialization
+
+v0.3.2 August 2015
+ * Fix: allow compilation with GHC 7.4
+
+v0.3.1 May 2015
+ * Fix: Bumping lens dependency and removing upper bound.
+
+v0.3 April 2015
+ * Breaking change: Switching all the numeric types associated to geometry
+   to Double precision (thx to Kasbah)
+
+v0.2 April 2015
+ * Fix: Differentiating opacity & fill-opacity, as they are
+   semantically deferent (BREAKING CHANGE!)
+
+v0.1.1 April 2015
+ * Fix: Bumping lens bounds
+
+v0.1.0.2 March 2015
+ * Fix: Bumping lens bounds
+
+v0.1.0.1
+ * Fix: Lowering some lower bounds
+
+v0.1
+ * Initial release
+

@@ -1,1624 +1,1631 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}--- | This module define all the types used in the definition--- of a svg scene.------ Most of the types are lensified.-module Graphics.Svg.Types-    ( -- * Basic building types-      Coord-    , Origin( .. )-    , Point-    , RPoint-    , PathCommand( .. )-    , Transformation( .. )-    , ElementRef( .. )-    , CoordinateUnits( .. )--      -- ** Building helpers-    , toPoint-    , serializeNumber-    , serializeTransformation-    , serializeTransformations--      -- * Drawing control types-    , Cap( .. )-    , LineJoin( .. )-    , Tree( .. )-    , Number( .. )-    , Spread( .. )-    , Texture( .. )-    , Element( .. )-    , FillRule( .. )-    , FontStyle( .. )-    , Dpi--    , WithDefaultSvg( .. )--      -- * Main type-    , Document( .. )-    , HasDocument( .. )-    , documentSize--      -- * Drawing attributes-    , DrawAttributes( .. )-    , HasDrawAttributes( .. )-    , WithDrawAttributes( .. )--      -- * SVG drawing primitives-      -- ** Rectangle-    , Rectangle( .. )-    , HasRectangle( .. )--      -- ** Line-    , Line( .. )-    , HasLine( .. )--      -- ** Polygon-    , Polygon( .. )-    , HasPolygon( .. )--      -- ** Polyline-    , PolyLine( .. )-    , HasPolyLine( .. )--      -- ** Path-    , Path( .. )-    , HasPath( .. )--      -- ** Circle-    , Circle( .. )-    , HasCircle( .. )--      -- ** Ellipse-    , Ellipse( .. )-    , HasEllipse( .. )--      -- ** Mesh (gradient mesh)-    , GradientPathCommand( .. )-    , MeshGradientType( .. )--    , MeshGradient( .. )-    , HasMeshGradient( .. )--    , MeshGradientRow( .. )-    , HasMeshGradientRow( .. )--    , MeshGradientPatch( .. )-    , HasMeshGradientPatch( .. )--      -- ** Image-    , Image( .. )-    , HasImage( .. )--      -- ** Use-    , Use( .. )-    , HasUse( .. )--      -- * Grouping primitives-      -- ** Group-    , Group( .. )-    , HasGroup( .. )--      -- ** Symbol-    , Symbol( .. )-    , groupOfSymbol--      -- * Text related types-      -- ** Text-    , Text( .. )-    , HasText( .. )-    , TextAnchor( .. )-    , textAt--      -- ** Text path-    , TextPath( .. )-    , HasTextPath( .. )--    , TextPathSpacing( .. )-    , TextPathMethod( .. )--      -- ** Text span.-    , TextSpanContent( .. )--    , TextSpan( .. )-    , HasTextSpan( .. )--    , TextInfo( .. )-    , HasTextInfo( .. )--    , TextAdjust( .. )--      -- * Marker definition-    , Marker( .. )-    , Overflow( .. )-    , MarkerOrientation( .. )-    , MarkerUnit( .. )-    , HasMarker( .. )--      -- * Gradient definition-    , GradientStop( .. )-    , HasGradientStop( .. )--      -- ** Linear Gradient-    , LinearGradient( .. )-    , HasLinearGradient( .. )--      -- ** Radial Gradient-    , RadialGradient( .. )-    , HasRadialGradient( .. )--      -- * Pattern definition-    , Pattern( .. )-    , HasPattern( .. )--      -- * Mask definition-    , Mask( .. )-    , HasMask( .. )--      -- * Clip path definition-    , ClipPath( .. )-    , HasClipPath( .. )--      -- * Aspect Ratio description-    , PreserveAspectRatio( .. )-    , Alignment( .. )-    , MeetSlice( .. )-    , HasPreserveAspectRatio( .. )--      -- * MISC functions-    , isPathArc-    , isPathWithArc-    , nameOfTree-    , zipTree-    , mapTree-    , foldTree-    , toUserUnit-    , mapNumber-    ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( Monoid( .. ) )-import Data.Foldable( Foldable )-#endif--import Data.Function( on )-import Data.List( inits )-import qualified Data.Map as M-import Data.Monoid( Last( .. ), (<>) )-import qualified Data.Foldable as F-import qualified Data.Text as T-import Codec.Picture( PixelRGBA8( .. ) )-import Control.Lens( Lens'-                   , lens-                   , makeClassy-                   , makeLenses-                   , view-                   , (^.)-                   , (&)-                   , (.~)-                   )-import Graphics.Svg.CssTypes-import Linear hiding ( angle )--import Text.Printf---- | Basic coordiante type.-type Coord = Double---- | Real Point, fully determined and not--- dependant of the rendering context.-type RPoint = V2 Coord---- | Possibly context dependant point.-type Point = (Number, Number)---- | Tell if a path command is absolute (in the current--- user coordiante) or relative to the previous poitn.-data Origin-  = OriginAbsolute -- ^ Next point in absolute coordinate-  | OriginRelative -- ^ Next point relative to the previous-  deriving (Eq, Show)--data MeshGradientType-  = GradientBilinear-  | GradientBicubic-  deriving (Eq, Show)---- | Path command definition.-data PathCommand-      -- | 'M' or 'm' command-    = MoveTo !Origin ![RPoint]-      -- | Line to, 'L' or 'l' Svg path command.-    | LineTo !Origin ![RPoint]--      -- | Equivalent to the 'H' or 'h' svg path command.-    | HorizontalTo  !Origin ![Coord]-      -- | Equivalent to the 'V' or 'v' svg path command.-    | VerticalTo    !Origin ![Coord]--    -- | Cubic bezier, 'C' or 'c' command-    | CurveTo  !Origin ![(RPoint, RPoint, RPoint)]-    -- | Smooth cubic bezier, equivalent to 'S' or 's' command-    | SmoothCurveTo  !Origin ![(RPoint, RPoint)]-    -- | Quadratic bezier, 'Q' or 'q' command-    | QuadraticBezier !Origin ![(RPoint, RPoint)]-    -- | Quadratic bezier, 'T' or 't' command-    | SmoothQuadraticBezierCurveTo  !Origin ![RPoint]-      -- | Eliptical arc, 'A' or 'a' command.-    | EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)]-      -- | Close the path, 'Z' or 'z' svg path command.-    | EndPath-    deriving (Eq, Show)---- | Description of path used in meshgradient tag-data GradientPathCommand-      -- | Line to, 'L' or 'l' Svg path command.-    = GLine !Origin !(Maybe RPoint)-      -- | Cubic bezier, 'C' or 'c' command-    | GCurve !Origin !RPoint !RPoint !(Maybe RPoint)-      -- | 'Z' command-    | GClose-    deriving (Eq, Show)---- | Little helper function to build a point.-toPoint :: Number -> Number -> Point-toPoint = (,)---- | Tell if the path command is an EllipticalArc.-isPathArc :: PathCommand -> Bool-isPathArc (EllipticalArc _ _) = True-isPathArc _ = False---- | Tell if a full path contain an EllipticalArc.-isPathWithArc :: Foldable f => f PathCommand -> Bool-isPathWithArc = F.any isPathArc---- | Define the possible values of various *units attributes--- used in the definition of the gradients and masks.-data CoordinateUnits-    = CoordUserSpace   -- ^ `userSpaceOnUse` value-    | CoordBoundingBox -- ^ `objectBoundingBox` value-    deriving (Eq, Show)---- | This type represent the align information of the--- preserveAspectRatio SVGattribute-data Alignment-  = AlignNone -- ^ "none" value-  | AlignxMinYMin -- "xMinYMin" value-  | AlignxMidYMin -- ^ "xMidYMin" value-  | AlignxMaxYMin -- ^ "xMaxYMin" value-  | AlignxMinYMid -- ^ "xMinYMid" value-  | AlignxMidYMid -- ^ "xMidYMid" value-  | AlignxMaxYMid -- ^ "xMaxYMid" value-  | AlignxMinYMax -- ^ "xMinYMax" value-  | AlignxMidYMax -- ^ "xMidYMax" value-  | AlignxMaxYMax -- ^ "xMaxYMax" value-  deriving (Eq, Show)---- | This type represent the "meet or slice" information--- of the preserveAspectRatio SVGattribute-data MeetSlice = Meet | Slice-    deriving (Eq, Show)---- | Describe the content of the preserveAspectRatio attribute.-data PreserveAspectRatio = PreserveAspectRatio-  { _aspectRatioDefer     :: !Bool-  , _aspectRatioAlign     :: !Alignment-  , _aspectRatioMeetSlice :: !(Maybe MeetSlice)-  }-  deriving (Eq, Show)---- | Lenses for the PreserveAspectRatio type-makeClassy ''PreserveAspectRatio --instance WithDefaultSvg PreserveAspectRatio where-  defaultSvg = PreserveAspectRatio -    { _aspectRatioDefer     = False-    , _aspectRatioAlign     = AlignxMidYMid-    , _aspectRatioMeetSlice = Nothing-    }---- | Describe how the line should be terminated--- when stroking them. Describe the values of the--- `stroke-linecap` attribute.--- See `_strokeLineCap`-data Cap-  = CapRound -- ^ End with a round (`round` value)-  | CapButt  -- ^ Define straight just at the end (`butt` value)-  | CapSquare -- ^ Straight further of the ends (`square` value)-  deriving (Eq, Show)---- | Define the possible values of the `stroke-linejoin`--- attribute.--- see `_strokeLineJoin`-data LineJoin-    = JoinMiter -- ^ `miter` value-    | JoinBevel -- ^ `bevel` value-    | JoinRound -- ^ `round` value-    deriving (Eq, Show)---- | Describe the different value which can be used--- in the `fill` or `stroke` attributes.-data Texture-  = ColorRef   PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb)-  | TextureRef String     -- ^ Link to a complex texture (url(#name))-  | FillNone              -- ^ Equivalent to the `none` value.-  deriving (Eq, Show)---- | Describe the possile filling algorithms.--- Map the values of the `fill-rule` attributes.-data FillRule-    = FillEvenOdd -- ^ Correspond to the `evenodd` value.-    | FillNonZero -- ^ Correspond to the `nonzero` value.-    deriving (Eq, Show)---- | Describe the content of the `transformation` attribute.--- see `_transform` and `transform`.-data Transformation-    = -- | Directly encode the translation matrix.-      TransformMatrix !Coord !Coord !Coord-                      !Coord !Coord !Coord-      -- | Translation along a vector-    | Translate !Double !Double-      -- | Scaling on both axis or on X axis and Y axis.-    | Scale !Double !(Maybe Double)-      -- | Rotation around `(0, 0)` or around an optional-      -- point.-    | Rotate !Double !(Maybe (Double, Double))-      -- | Skew transformation along the X axis.-    | SkewX !Double-      -- | Skew transformation along the Y axis.-    | SkewY !Double-      -- | Unkown transformation, like identity.-    | TransformUnknown-    deriving (Eq, Show)---- | Convert the Transformation to a string which can be--- directly used in a svg attributes.-serializeTransformation :: Transformation -> String-serializeTransformation t = case t of-  TransformUnknown -> ""-  TransformMatrix a b c d e f ->-      printf "matrix(%g, %g, %g, %g, %g, %g)" a b c d e f-  Translate x y -> printf "translate(%g, %g)" x y-  Scale x Nothing -> printf "scale(%g)" x-  Scale x (Just y) -> printf "scale(%g, %g)" x y-  Rotate angle Nothing -> printf "rotate(%g)" angle-  Rotate angle (Just (x, y))-> printf "rotate(%g, %g, %g)" angle x y-  SkewX x -> printf "skewX(%g)" x-  SkewY y -> printf "skewY(%g)" y---- | Transform a list of transformations to a string for svg--- `transform` attributes.-serializeTransformations :: [Transformation] -> String-serializeTransformations =-    unwords . fmap serializeTransformation---- | Class helping find the drawing attributes for all--- the SVG attributes.-class WithDrawAttributes a where-    -- | Lens which can be used to read/write primitives.-    drawAttr :: Lens' a DrawAttributes---- | Define an empty 'default' element for the SVG tree.--- It is used as base when parsing the element from XML.-class WithDefaultSvg a where-    -- | The default element.-    defaultSvg :: a---- | Classify the font style, used to search a matching--- font in the FontCache.-data FontStyle-  = FontStyleNormal-  | FontStyleItalic-  | FontStyleOblique-  deriving (Eq, Show)---- | Tell where to anchor the text, where the position--- given is realative to the text.-data TextAnchor-    -- | The text with left aligned, or start at the postion-    -- If the point is the '*' then the text will be printed-    -- this way:-    ---    -- >  *THE_TEXT_TO_PRINT-    ---    -- Equivalent to the `start` value.-  = TextAnchorStart-    -- | The text is middle aligned, so the text will be at-    -- the left and right of the position:-    ---    -- >   THE_TEXT*TO_PRINT-    ---    -- Equivalent to the `middle` value.-  | TextAnchorMiddle-    -- | The text is right aligned.-    ---    -- >   THE_TEXT_TO_PRINT*-    ---    -- Equivalent to the `end` value.-  | TextAnchorEnd-  deriving (Eq, Show)----- | Correspond to the possible values of the--- the attributes which are either `none` or--- `url(#elem)`-data ElementRef-  = RefNone  -- ^ Value for `none`-  | Ref String -- ^ Equivalent to `url()` attribute.-  deriving (Eq, Show)---- | This type define how to draw any primitives,--- which color to use, how to stroke the primitives--- and the potential transformations to use.------ All these attributes are propagated to the children.-data DrawAttributes = DrawAttributes-    { -- | Attribute corresponding to the `stroke-width`-      -- SVG attribute.-      _strokeWidth      :: !(Last Number)-      -- | Correspond to the `stroke` attribute.-    , _strokeColor      :: !(Last Texture)-      -- | Define the `stroke-opacity` attribute, the transparency-      -- for the "border".-    , _strokeOpacity    :: !(Maybe Float)-      -- | Correspond to the `stroke-linecap` SVG-      -- attribute-    , _strokeLineCap    :: !(Last Cap)-      -- | Correspond to the `stroke-linejoin` SVG-      -- attribute-    , _strokeLineJoin   :: !(Last LineJoin)-      -- | Define the distance of the miter join, correspond-      -- to the `stroke-miterlimit` attritbue.-    , _strokeMiterLimit :: !(Last Double)-      -- | Define the filling color of the elements. Corresponding-      -- to the `fill` attribute.-    , _fillColor        :: !(Last Texture)-      -- | Define the `fill-opacity` attribute, the transparency-      -- for the "content".-    , _fillOpacity      :: !(Maybe Float)-      -- | Define the global or group opacity attribute.-    , _groupOpacity     :: !(Maybe Float)-      -- | Content of the `transform` attribute-    , _transform        :: !(Maybe [Transformation])-      -- | Define the `fill-rule` used during the rendering.-    , _fillRule         :: !(Last FillRule)-      -- | Define the `mask` attribute.-    , _maskRef          :: !(Last ElementRef)-      -- | Define the `clip-path` attribute.-    , _clipPathRef      :: !(Last ElementRef)-      -- | Define the `clip-rule` attribute.-    , _clipRule         :: !(Last FillRule)-      -- | Map to the `class` attribute. Used for the CSS-      -- rewriting.-    , _attrClass        :: ![T.Text]-      -- | Map to the `id` attribute. Used for the CSS-      -- rewriting.-    , _attrId           :: !(Maybe String)-      -- | Define the start distance of the dashing pattern.-      -- Correspond to the `stroke-dashoffset` attribute.-    , _strokeOffset     :: !(Last Number)-      -- | Define the dashing pattern for the lines. Correspond-      -- to the `stroke-dasharray` attribute.-    , _strokeDashArray  :: !(Last [Number])-      -- | Current size of the text, correspond to the-      -- `font-size` SVG attribute.-    , _fontSize         :: !(Last Number)-      -- | Define the possible fonts to be used for text rendering.-      -- Map to the `font-family` attribute.-    , _fontFamily       :: !(Last [String])-      -- | Map to the `font-style` attribute.-    , _fontStyle        :: !(Last FontStyle)-      -- | Define how to interpret the text position, correspond-      -- to the `text-anchor` attribute.-    , _textAnchor       :: !(Last TextAnchor)-      -- | Define the marker used for the start of the line.-      -- Correspond to the `marker-start` attribute.-    , _markerStart      :: !(Last ElementRef)-      -- | Define the marker used for every point of the-      -- polyline/path Correspond to the `marker-mid`-      -- attribute.-    , _markerMid        :: !(Last ElementRef)-      -- | Define the marker used for the end of the line.-      -- Correspond to the `marker-end` attribute.-    , _markerEnd        :: !(Last ElementRef)-    }-    deriving (Eq, Show)---- | Lenses for the DrawAttributes type.-makeClassy ''DrawAttributes---- | This primitive describe an unclosed suite of--- segments. Correspond to the `<polyline>` tag.-data PolyLine = PolyLine-  { -- | drawing attributes of the polyline.-    _polyLineDrawAttributes :: !DrawAttributes--    -- | Geometry definition of the polyline.-    -- correspond to the `points` attribute-  , _polyLinePoints :: ![RPoint]-  }-  deriving (Eq, Show)---- | Lenses for the PolyLine type.-makeClassy ''PolyLine--instance WithDefaultSvg PolyLine where-  defaultSvg = PolyLine-    { _polyLineDrawAttributes = mempty-    , _polyLinePoints = []-    }---instance WithDrawAttributes PolyLine where-    drawAttr = polyLineDrawAttributes---- | Primitive decriving polygon composed--- of segements. Correspond to the `<polygon>`--- tag-data Polygon = Polygon-  { -- | Drawing attributes for the polygon.-    _polygonDrawAttributes :: !DrawAttributes-    -- | Points of the polygon. Correspond to-    -- the `points` attributes.-  , _polygonPoints :: ![RPoint]-  }-  deriving (Eq, Show)---- | Lenses for the Polygon type-makeClassy ''Polygon--instance WithDrawAttributes Polygon where-    drawAttr = polygonDrawAttributes--instance WithDefaultSvg Polygon where-  defaultSvg = Polygon-    { _polygonDrawAttributes = mempty-    , _polygonPoints = []-    }---- | Define a simple line. Correspond to the--- `<line>` tag.-data Line = Line-  { -- | Drawing attributes of line.-    _lineDrawAttributes :: !DrawAttributes-    -- | First point of the the line, correspond-    -- to the `x1` and `y1` attributes.-  , _linePoint1 :: !Point-    -- | Second point of the the line, correspond-    -- to the `x2` and `y2` attributes.-  , _linePoint2 :: !Point-  }-  deriving (Eq, Show)---- | Lenses for the Line type.-makeClassy ''Line--instance WithDrawAttributes Line where-    drawAttr = lineDrawAttributes--instance WithDefaultSvg Line where-  defaultSvg = Line-    { _lineDrawAttributes = mempty-    , _linePoint1 = zeroPoint-    , _linePoint2 = zeroPoint-    }-    where zeroPoint = (Num 0, Num 0)---- | Define a rectangle. Correspond to--- `<rectangle>` svg tag.-data Rectangle = Rectangle-  { -- | Rectangle drawing attributes.-    _rectDrawAttributes  :: !DrawAttributes-    -- | Upper left corner of the rectangle, correspond-    -- to the attributes `x` and `y`.-  , _rectUpperLeftCorner :: !Point-    -- | Rectangle width, correspond, strangely, to-    -- the `width` attribute.-  , _rectWidth           :: !Number-    -- | Rectangle height, correspond, amazingly, to-    -- the `height` attribute.-  , _rectHeight          :: !Number-    -- | Define the rounded corner radius radius-    -- of the rectangle. Correspond to the `rx` and-    -- `ry` attributes.-  , _rectCornerRadius    :: !(Number, Number)-  }-  deriving (Eq, Show)---- | Lenses for the Rectangle type.-makeClassy ''Rectangle--instance WithDrawAttributes Rectangle where-    drawAttr = rectDrawAttributes--instance WithDefaultSvg Rectangle where-  defaultSvg = Rectangle-    { _rectDrawAttributes  = mempty-    , _rectUpperLeftCorner = (Num 0, Num 0)-    , _rectWidth           = Num 0-    , _rectHeight          = Num 0-    , _rectCornerRadius    = (Num 0, Num 0)-    }---- | Type mapping the `<path>` svg tag.-data Path = Path-  { -- | Drawing attributes of the path.-    _pathDrawAttributes :: !DrawAttributes-    -- | Definition of the path, correspond to the-    -- `d` attributes.-  , _pathDefinition :: ![PathCommand]-  }-  deriving (Eq, Show)---- | Lenses for the Path type-makeClassy ''Path--instance WithDrawAttributes Path where-  drawAttr = pathDrawAttributes--instance WithDefaultSvg Path where-  defaultSvg = Path-    { _pathDrawAttributes = mempty-    , _pathDefinition = []-    }---- | Define a SVG group, corresponding `<g>` tag.-data Group a = Group-  { -- | Group drawing attributes, propagated to all of its-    -- children.-    _groupDrawAttributes :: !DrawAttributes-    -- | Content of the group, corresponding to all the tags-    -- inside the `<g>` tag.-  , _groupChildren  :: ![a]-    -- | Mapped to the attribute `viewBox`-  , _groupViewBox   :: !(Maybe (Double, Double, Double, Double))-    -- | used for symbols only-  , _groupAspectRatio :: !PreserveAspectRatio-  }-  deriving (Eq, Show)---- | Lenses associated to the Group type.-makeClassy ''Group--instance WithDrawAttributes (Group a) where-    drawAttr = groupDrawAttributes--instance WithDefaultSvg (Group a) where-  defaultSvg = Group-    { _groupDrawAttributes = mempty-    , _groupChildren  = []-    , _groupViewBox = Nothing-    , _groupAspectRatio = defaultSvg-    }---- | Define the `<symbol>` tag, equivalent to--- a named group.-newtype Symbol a =-    Symbol { _groupOfSymbol :: Group a }-  deriving (Eq, Show)---- | Lenses associated with the Symbol type.-makeLenses ''Symbol--instance WithDrawAttributes (Symbol a) where-  drawAttr = groupOfSymbol . drawAttr--instance WithDefaultSvg (Symbol a) where-  defaultSvg = Symbol defaultSvg---- | Define a `<circle>`.-data Circle = Circle-  { -- | Drawing attributes of the circle.-    _circleDrawAttributes :: !DrawAttributes-    -- | Define the center of the circle, describe-    -- the `cx` and `cy` attributes.-  , _circleCenter   :: !Point-    -- | Radius of the circle, equivalent to the `r`-    -- attribute.-  , _circleRadius   :: !Number-  }-  deriving (Eq, Show)---- | Lenses for the Circle type.-makeClassy ''Circle--instance WithDrawAttributes Circle where-    drawAttr = circleDrawAttributes--instance WithDefaultSvg Circle where-  defaultSvg = Circle-    { _circleDrawAttributes = mempty-    , _circleCenter = (Num 0, Num 0)-    , _circleRadius = Num 0-    }---- | Define an `<ellipse>`-data Ellipse = Ellipse-  {  -- | Drawing attributes of the ellipse.-    _ellipseDrawAttributes :: !DrawAttributes-    -- | Center of the ellipse, map to the `cx`-    -- and `cy` attributes.-  , _ellipseCenter :: !Point-    -- | Radius along the X axis, map the-    -- `rx` attribute.-  , _ellipseXRadius :: !Number-    -- | Radius along the Y axis, map the-    -- `ry` attribute.-  , _ellipseYRadius :: !Number-  }-  deriving (Eq, Show)---- | Lenses for the ellipse type.-makeClassy ''Ellipse--instance WithDrawAttributes Ellipse where-  drawAttr = ellipseDrawAttributes--instance WithDefaultSvg Ellipse where-  defaultSvg = Ellipse-    { _ellipseDrawAttributes = mempty-    , _ellipseCenter = (Num 0, Num 0)-    , _ellipseXRadius = Num 0-    , _ellipseYRadius = Num 0-    }---- | Define a color stop for the gradients. Represent--- the `<stop>` SVG tag.-data GradientStop = GradientStop-    { -- | Gradient offset between 0 and 1, correspond-      -- to the `offset` attribute.-      _gradientOffset :: !Float-      -- | Color of the gradient stop. Correspond-      -- to the `stop-color` attribute.-    , _gradientColor  :: !PixelRGBA8-      -- | Path command used in mesh patch-    , _gradientPath   :: !(Maybe GradientPathCommand)-      -- | Stop color opacity-    , _gradientOpacity :: !(Maybe Float)-    }-    deriving (Eq, Show)---- | Lenses for the GradientStop type.-makeClassy ''GradientStop--instance WithDefaultSvg GradientStop where-  defaultSvg = GradientStop-    { _gradientOffset = 0.0-    , _gradientColor  = PixelRGBA8 0 0 0 255-    , _gradientPath   = Nothing-    , _gradientOpacity = Nothing-    }----- | Define `<meshpatch>` SVG tag-data MeshGradientPatch = MeshGradientPatch-  { -- | List of stop, from 2 to 4 in a patch-    _meshGradientPatchStops :: ![GradientStop]-  }-  deriving (Eq, Show)--makeClassy ''MeshGradientPatch--instance WithDefaultSvg MeshGradientPatch where-  defaultSvg = MeshGradientPatch []---- | Define a `<meshrow>` tag.-data MeshGradientRow = MeshGradientRow-  { -- | List of patch in a row-    _meshGradientRowPatches :: ![MeshGradientPatch]-  }-  deriving (Eq, Show)--makeClassy ''MeshGradientRow--instance WithDefaultSvg MeshGradientRow where-  defaultSvg = MeshGradientRow []----- | Define a `<meshgradient>` tag.-data MeshGradient = MeshGradient-  { _meshGradientDrawAttributes :: !DrawAttributes-    -- | Original x coordinate of the mesh gradient-  , _meshGradientX              :: !Number-    -- | Original y coordinate of the mesh gradient-  , _meshGradientY              :: !Number-    -- | Type of color interpolation to use-  , _meshGradientType           :: !MeshGradientType-    -- | Coordiante system to use-  , _meshGradientUnits          :: !CoordinateUnits-    -- | Optional transform-  , _meshGradientTransform      :: ![Transformation]-    -- | List of patch rows in the the mesh.-  , _meshGradientRows           :: ![MeshGradientRow]-  }-  deriving (Eq, Show)--makeClassy ''MeshGradient--instance WithDrawAttributes MeshGradient where-  drawAttr = meshGradientDrawAttributes--instance WithDefaultSvg MeshGradient where-  defaultSvg = MeshGradient-    { _meshGradientDrawAttributes = mempty-    , _meshGradientX              = Percent 0-    , _meshGradientY              = Percent 0-    , _meshGradientType           = GradientBilinear-    , _meshGradientUnits          = CoordBoundingBox-    , _meshGradientTransform      = mempty-    , _meshGradientRows           = mempty-    }----- | Define an `<image>` tag.-data Image = Image-  { -- | Drawing attributes of the image-    _imageDrawAttributes :: !DrawAttributes-    -- | Position of the image referenced by its-    -- upper left corner.-  , _imageCornerUpperLeft :: !Point-    -- | Image width-  , _imageWidth :: !Number-    -- | Image Height-  , _imageHeight :: !Number-    -- | Image href, pointing to the real image.-  , _imageHref :: !String-    -- | preserveAspectRatio attribute-  , _imageAspectRatio :: !PreserveAspectRatio-  }-  deriving (Eq, Show)---- | Lenses for the Image type.-makeClassy ''Image--instance WithDrawAttributes Image where-  drawAttr = imageDrawAttributes--instance WithDefaultSvg Image where-  defaultSvg = Image-    { _imageDrawAttributes = mempty-    , _imageCornerUpperLeft = (Num 0, Num 0)-    , _imageWidth = Num 0-    , _imageHeight = Num 0-    , _imageHref = ""-    , _imageAspectRatio = defaultSvg-    }---- | Define an `<use>` for a named content.--- Every named content can be reused in the--- document using this element.-data Use = Use-  { -- | Position where to draw the "used" element.-    -- Correspond to the `x` and `y` attributes.-    _useBase   :: Point-    -- | Referenced name, correspond to `xlink:href`-    -- attribute.-  , _useName   :: String-    -- | Define the width of the region where-    -- to place the element. Map to the `width`-    -- attribute.-  , _useWidth  :: Maybe Number-    -- | Define the height of the region where-    -- to place the element. Map to the `height`-    -- attribute.-  , _useHeight :: Maybe Number-    -- | Use draw attributes.-  , _useDrawAttributes :: DrawAttributes-  }-  deriving (Eq, Show)---- | Lenses for the Use type.-makeClassy ''Use--instance WithDrawAttributes Use where-  drawAttr = useDrawAttributes--instance WithDefaultSvg Use where-  defaultSvg = Use-    { _useBase   = (Num 0, Num 0)-    , _useName   = ""-    , _useWidth  = Nothing-    , _useHeight = Nothing-    , _useDrawAttributes = mempty-    }---- | Define position information associated to--- `<text>` or `<tspan>` svg tag.-data TextInfo = TextInfo-  { _textInfoX      :: ![Number] -- ^ `x` attribute.-  , _textInfoY      :: ![Number] -- ^ `y` attribute.-  , _textInfoDX     :: ![Number] -- ^ `dx` attribute.-  , _textInfoDY     :: ![Number] -- ^ `dy` attribute.-  , _textInfoRotate :: ![Double] -- ^ `rotate` attribute.-  , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute.-  }-  deriving (Eq, Show)--instance Monoid TextInfo where-  mempty = TextInfo [] [] [] [] [] Nothing-  mappend (TextInfo x1 y1 dx1 dy1 r1 l1)-          (TextInfo x2 y2 dx2 dy2 r2 l2) =-    TextInfo (x1 <> x2)   (y1 <> y2)-                (dx1 <> dx2) (dy1 <> dy2)-                (r1 <> r2)-                (getLast $ Last l1 <> Last l2)---- | Lenses for the TextInfo type.-makeClassy ''TextInfo--instance WithDefaultSvg TextInfo where-  defaultSvg = mempty---- | Define the content of a `<tspan>` tag.-data TextSpanContent-    = SpanText    !T.Text -- ^ Raw text-    | SpanTextRef !String -- ^ Equivalent to a `<tref>`-    | SpanSub     !TextSpan -- ^ Define a `<tspan>`-    deriving (Eq, Show)---- | Define a `<tspan>` tag.-data TextSpan = TextSpan-  { -- | Placing information for the text.-    _spanInfo           :: !TextInfo-    -- | Drawing attributes for the text span.-  , _spanDrawAttributes :: !DrawAttributes-    -- | Content of the span.-  , _spanContent        :: ![TextSpanContent]-  }-  deriving (Eq, Show)---- | Lenses for the TextSpan type.-makeClassy ''TextSpan--instance WithDefaultSvg TextSpan where-  defaultSvg = TextSpan-    { _spanInfo = defaultSvg-    , _spanDrawAttributes = mempty-    , _spanContent        = mempty-    }---- | Describe the content of the `method` attribute on--- text path.-data TextPathMethod-  = TextPathAlign   -- ^ Map to the `align` value.-  | TextPathStretch -- ^ Map to the `stretch` value.-  deriving (Eq, Show)---- | Describe the content of the `spacing` text path--- attribute.-data TextPathSpacing-  = TextPathSpacingExact -- ^ Map to the `exact` value.-  | TextPathSpacingAuto  -- ^ Map to the `auto` value.-  deriving (Eq, Show)---- | Describe the `<textpath>` SVG tag.-data TextPath = TextPath-  { -- | Define the beginning offset on the path,-    -- the `startOffset` attribute.-    _textPathStartOffset :: !Number-    -- | Define the `xlink:href` attribute.-  , _textPathName        :: !String-    -- | Correspond to the `method` attribute.-  , _textPathMethod      :: !TextPathMethod-    -- | Correspond to the `spacing` attribute.-  , _textPathSpacing     :: !TextPathSpacing-    -- | Real content of the path.-  , _textPathData        :: ![PathCommand]-  }-  deriving (Eq, Show)---- | Lenses for the TextPath type.-makeClassy ''TextPath--instance WithDefaultSvg TextPath where-  defaultSvg = TextPath-    { _textPathStartOffset = Num 0-    , _textPathName        = mempty-    , _textPathMethod      = TextPathAlign-    , _textPathSpacing     = TextPathSpacingExact-    , _textPathData        = []-    }---- | Define the possible values of the `lengthAdjust`--- attribute.-data TextAdjust-  = TextAdjustSpacing -- ^ Value `spacing`-  | TextAdjustSpacingAndGlyphs -- ^ Value `spacingAndGlyphs`-  deriving (Eq, Show)---- | Define the global `<tag>` SVG tag.-data Text = Text-  { -- | Define the `lengthAdjust` attribute.-    _textAdjust   :: !TextAdjust-    -- | Root of the text content.-  , _textRoot     :: !TextSpan-  }-  deriving (Eq, Show)---- | Lenses for the Text type.-makeClassy ''Text---- | Little helper to create a SVG text at a given--- baseline position.-textAt :: Point -> T.Text -> Text-textAt (x, y) txt = Text TextAdjustSpacing tspan where-  tspan = defaultSvg-        { _spanContent = [SpanText txt]-        , _spanInfo = defaultSvg-                    { _textInfoX = [x]-                    , _textInfoY = [y]-                    }-        }--instance WithDrawAttributes Text where-  drawAttr = textRoot . spanDrawAttributes--instance WithDefaultSvg Text where-  defaultSvg = Text-    { _textRoot = defaultSvg-    , _textAdjust = TextAdjustSpacing-    }---- | Main type for the scene description, reorient to--- specific type describing each tag.-data Tree-    = None-    | UseTree { useInformation :: !Use-              , useSubTree     :: !(Maybe Tree) }-    | GroupTree     !(Group Tree)-    | SymbolTree    !(Symbol Tree)-    | PathTree      !Path-    | CircleTree    !Circle-    | PolyLineTree  !PolyLine-    | PolygonTree   !Polygon-    | EllipseTree   !Ellipse-    | LineTree      !Line-    | RectangleTree !Rectangle-    | TextTree      !(Maybe TextPath) !Text-    | ImageTree     !Image-    | MeshGradientTree !MeshGradient-    deriving (Eq, Show)---- | Define the orientation, associated to the--- `orient` attribute on the Marker-data MarkerOrientation-  = OrientationAuto        -- ^ Auto value-  | OrientationAngle Coord -- ^ Specific angle.-  deriving (Eq, Show)---- | Define the content of the `markerUnits` attribute--- on the Marker.-data MarkerUnit-  = MarkerUnitStrokeWidth    -- ^ Value `strokeWidth`-  | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse`-  deriving (Eq, Show)---- | Define the content of the `markerUnits` attribute--- on the Marker.-data Overflow-  = OverflowVisible    -- ^ Value `visible`-  | OverflowHidden     -- ^ Value `hidden`-  deriving (Eq, Show)---- | Define the `<marker>` tag.-data Marker = Marker-  { -- | Draw attributes of the marker.-    _markerDrawAttributes :: DrawAttributes-    -- | Define the reference point of the marker.-    -- correspond to the `refX` and `refY` attributes.-  , _markerRefPoint    :: !(Number, Number)-    -- | Define the width of the marker. Correspond to-    -- the `markerWidth` attribute.-  , _markerWidth       :: !(Maybe Number)-    -- | Define the height of the marker. Correspond to-    -- the `markerHeight` attribute.-  , _markerHeight      :: !(Maybe Number)-    -- | Correspond to the `orient` attribute.-  , _markerOrient      :: !(Maybe MarkerOrientation)-    -- | Map the `markerUnits` attribute.-  , _markerUnits       :: !(Maybe MarkerUnit)-    -- | Optional viewbox-  , _markerViewBox     :: !(Maybe (Double, Double, Double, Double))-    -- | Elements defining the marker.-  , _markerOverflow    :: !(Maybe Overflow)-    -- | preserveAspectRatio attribute-  , _markerAspectRatio :: !PreserveAspectRatio-    -- | Elements defining the marker.-  , _markerElements :: [Tree]-  }-  deriving (Eq, Show)---- | Lenses for the Marker type.-makeClassy ''Marker--instance WithDrawAttributes Marker where-    drawAttr = markerDrawAttributes--instance WithDefaultSvg Marker where-  defaultSvg = Marker-    { _markerDrawAttributes = mempty-    , _markerRefPoint = (Num 0, Num 0)-    , _markerWidth = Just (Num 3)-    , _markerHeight = Just (Num 3)-    , _markerOrient = Nothing -- MarkerOrientation-    , _markerUnits = Nothing -- MarkerUnitStrokeWidth-    , _markerViewBox = Nothing-    , _markerOverflow = Nothing-    , _markerElements = mempty-    , _markerAspectRatio = defaultSvg-    }---- | Insert element in the first sublist in the list of list.-appNode :: [[a]] -> a -> [[a]]-appNode [] e = [[e]]-appNode (curr:above) e = (e:curr) : above---- | Map a tree while propagating context information.--- The function passed in parameter receive a list--- representing the the path used to go arrive to the--- current node.-zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree-zipTree f = dig [] where-  dig prev e@None = f $ appNode prev e-  dig prev e@(UseTree _ Nothing) = f $ appNode prev e-  dig prev e@(UseTree nfo (Just u)) =-      f . appNode prev . UseTree nfo . Just $ dig ([] : appNode prev e) u-  dig prev e@(GroupTree g) =-      f . appNode prev . GroupTree $ zipGroup (appNode prev e) g-  dig prev e@(SymbolTree g) =-      f . appNode prev . SymbolTree . Symbol .-            zipGroup (appNode prev e) $ _groupOfSymbol g-  dig prev e@(PathTree _) = f $ appNode prev e-  dig prev e@(CircleTree _) = f $ appNode prev e-  dig prev e@(PolyLineTree _) = f $ appNode prev e-  dig prev e@(PolygonTree _) = f $ appNode prev e-  dig prev e@(EllipseTree _) = f $ appNode prev e-  dig prev e@(LineTree _) = f $ appNode prev e-  dig prev e@(RectangleTree _) = f $ appNode prev e-  dig prev e@(TextTree _ _) = f $ appNode prev e-  dig prev e@(ImageTree _) = f $ appNode prev e-  dig prev e@(MeshGradientTree _) = f $ appNode prev e--  zipGroup prev g = g { _groupChildren = updatedChildren }-    where-      groupChild = _groupChildren g-      updatedChildren =-        [dig (c:prev) child-            | (child, c) <- zip groupChild $ inits groupChild]---- | Fold all nodes of a SVG tree.-foldTree :: (a -> Tree -> a) -> a -> Tree -> a-foldTree f = go where-  go acc e = case e of-    None            -> f acc e-    UseTree _ _     -> f acc e-    PathTree _      -> f acc e-    CircleTree _    -> f acc e-    PolyLineTree _  -> f acc e-    PolygonTree _   -> f acc e-    EllipseTree _   -> f acc e-    LineTree _      -> f acc e-    RectangleTree _ -> f acc e-    TextTree    _ _ -> f acc e-    ImageTree _     -> f acc e-    MeshGradientTree _ -> f acc e-    GroupTree g     ->-      let subAcc = F.foldl' go acc $ _groupChildren g in-      f subAcc e-    SymbolTree s    ->-      let subAcc =-            F.foldl' go acc . _groupChildren $ _groupOfSymbol s in-      f subAcc e---- | Helper function mapping every tree element.-mapTree :: (Tree -> Tree) -> Tree -> Tree-mapTree f = go where-  go e@None = f e-  go e@(UseTree _ _) = f e-  go (GroupTree g) = f . GroupTree $ mapGroup g-  go (SymbolTree g) =-      f . SymbolTree . Symbol . mapGroup $ _groupOfSymbol g-  go e@(PathTree _) = f e-  go e@(CircleTree _) = f e-  go e@(PolyLineTree _) = f e-  go e@(PolygonTree _) = f e-  go e@(EllipseTree _) = f e-  go e@(LineTree _) = f e-  go e@(RectangleTree _) = f e-  go e@(TextTree _ _) = f e-  go e@(ImageTree _) = f e-  go e@(MeshGradientTree _) = f e--  mapGroup g =-      g { _groupChildren = map go $ _groupChildren g }---- | For every element of a svg tree, associate--- it's SVG tag name.-nameOfTree :: Tree -> T.Text-nameOfTree v =-  case v of-   None     -> ""-   UseTree _ _     -> "use"-   GroupTree _     -> "g"-   SymbolTree _    -> "symbol"-   PathTree _      -> "path"-   CircleTree _    -> "circle"-   PolyLineTree _  -> "polyline"-   PolygonTree _   -> "polygon"-   EllipseTree _   -> "ellipse"-   LineTree _      -> "line"-   RectangleTree _ -> "rectangle"-   TextTree    _ _ -> "text"-   ImageTree _     -> "image"-   MeshGradientTree _ -> "meshgradient"--drawAttrOfTree :: Tree -> DrawAttributes-drawAttrOfTree v = case v of-  None -> mempty-  UseTree e _ -> e ^. drawAttr-  GroupTree e -> e ^. drawAttr-  SymbolTree e -> e ^. drawAttr-  PathTree e -> e ^. drawAttr-  CircleTree e -> e ^. drawAttr-  PolyLineTree e -> e ^. drawAttr-  PolygonTree e -> e ^. drawAttr-  EllipseTree e -> e ^. drawAttr-  LineTree e -> e ^. drawAttr-  RectangleTree e -> e ^. drawAttr-  TextTree _ e -> e ^. drawAttr-  ImageTree e -> e ^. drawAttr-  MeshGradientTree e -> e ^. drawAttr--setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree-setDrawAttrOfTree v attr = case v of-  None -> None-  UseTree e m -> UseTree (e & drawAttr .~ attr) m-  GroupTree e -> GroupTree $ e & drawAttr .~ attr-  SymbolTree e -> SymbolTree $ e & drawAttr .~ attr-  PathTree e -> PathTree $ e & drawAttr .~ attr-  CircleTree e -> CircleTree $ e & drawAttr .~ attr-  PolyLineTree e -> PolyLineTree $ e & drawAttr .~ attr-  PolygonTree e -> PolygonTree $ e & drawAttr .~ attr-  EllipseTree e -> EllipseTree $ e & drawAttr .~ attr-  LineTree e -> LineTree $ e & drawAttr .~ attr-  RectangleTree e -> RectangleTree $ e & drawAttr .~ attr-  TextTree a e -> TextTree a $ e & drawAttr .~ attr-  ImageTree e -> ImageTree $ e & drawAttr .~ attr-  MeshGradientTree e -> MeshGradientTree $ e & drawAttr .~ attr--instance WithDrawAttributes Tree where-    drawAttr = lens drawAttrOfTree setDrawAttrOfTree--instance WithDefaultSvg Tree where-    defaultSvg = None---- | Define the possible values for the `spreadMethod`--- values used for the gradient definitions.-data Spread-    = SpreadRepeat  -- ^ `reapeat` value-    | SpreadPad     -- ^ `pad` value-    | SpreadReflect -- ^ `reflect value`-    deriving (Eq, Show)---- | Define a `<linearGradient>` tag.-data LinearGradient = LinearGradient-    { -- | Define coordinate system of the gradient,-      -- associated to the `gradientUnits` attribute.-      _linearGradientUnits  :: CoordinateUnits-      -- | Point defining the beginning of the line gradient.-      -- Associated to the `x1` and `y1` attribute.-    , _linearGradientStart  :: Point-      -- | Point defining the end of the line gradient.-      -- Associated to the `x2` and `y2` attribute.-    , _linearGradientStop   :: Point-      -- | Define how to handle the values outside-      -- the gradient start and stop. Associated to the-      -- `spreadMethod` attribute.-    , _linearGradientSpread :: Spread-      -- | Define the transformation to apply to the-      -- gradient points. Associated to the `gradientTransform`-      -- attribute.-    , _linearGradientTransform :: [Transformation]-      -- | List of color stops of the linear gradient.-    , _linearGradientStops  :: [GradientStop]-    }-    deriving (Eq, Show)---- | Lenses for the LinearGradient type.-makeClassy ''LinearGradient--instance WithDefaultSvg LinearGradient where-  defaultSvg = LinearGradient-    { _linearGradientUnits     = CoordBoundingBox-    , _linearGradientStart     = (Percent 0, Percent 0)-    , _linearGradientStop      = (Percent 1, Percent 0)-    , _linearGradientSpread    = SpreadPad-    , _linearGradientTransform = []-    , _linearGradientStops     = []-    }---- | Define a `<radialGradient>` tag.-data RadialGradient = RadialGradient-  { -- | Define coordinate system of the gradient,-    -- associated to the `gradientUnits` attribute.-    _radialGradientUnits   :: CoordinateUnits-    -- | Center of the radial gradient. Associated to-    -- the `cx` and `cy` attributes.-  , _radialGradientCenter  :: Point-    -- | Radius of the radial gradient. Associated to-    -- the `r` attribute.-  , _radialGradientRadius  :: Number-    -- | X coordinate of the focus point of the radial-    -- gradient. Associated to the `fx` attribute.-  , _radialGradientFocusX  :: Maybe Number-    -- | Y coordinate of the focus point of the radial-    -- gradient. Associated to the `fy` attribute.-  , _radialGradientFocusY  :: Maybe Number-    -- | Define how to handle the values outside-    -- the gradient start and stop. Associated to the-    -- `spreadMethod` attribute.-  , _radialGradientSpread  :: Spread-    -- | Define the transformation to apply to the-    -- gradient points. Associated to the `gradientTransform`-    -- attribute.-  , _radialGradientTransform :: [Transformation]-    -- | List of color stops of the radial gradient.-  , _radialGradientStops   :: [GradientStop]-  }-  deriving (Eq, Show)---- | Lenses for the RadialGradient type.-makeClassy ''RadialGradient--instance WithDefaultSvg RadialGradient where-  defaultSvg = RadialGradient-    { _radialGradientUnits   = CoordBoundingBox-    , _radialGradientCenter  = (Percent 0.5, Percent 0.5)-    , _radialGradientRadius  = Percent 0.5-    , _radialGradientFocusX  = Nothing-    , _radialGradientFocusY  = Nothing-    , _radialGradientSpread  = SpreadPad-    , _radialGradientTransform = []-    , _radialGradientStops   = []-    }---- | Define a SVG `<mask>` tag.-data Mask = Mask-  { -- | Drawing attributes of the Mask-    _maskDrawAttributes :: DrawAttributes-    -- | Correspond to the `maskContentUnits` attributes.-  , _maskContentUnits :: CoordinateUnits-    -- | Mapping to the `maskUnits` attribute.-  , _maskUnits        :: CoordinateUnits-    -- | Map to the `x` and `y` attributes.-  , _maskPosition     :: Point-    -- | Map to the `width` attribute-  , _maskWidth        :: Number-    -- | Map to the `height` attribute.-  , _maskHeight       :: Number-    -- | Children of the `<mask>` tag.-  , _maskContent      :: [Tree]-  }-  deriving (Eq, Show)---- | Lenses for the Mask type.-makeClassy ''Mask--instance WithDrawAttributes Mask where-  drawAttr = maskDrawAttributes--instance WithDefaultSvg Mask where-  defaultSvg = Mask-    { _maskDrawAttributes = mempty-    , _maskContentUnits = CoordUserSpace-    , _maskUnits        = CoordBoundingBox-    , _maskPosition     = (Percent (-0.1), Percent (-0.1))-    , _maskWidth        = Percent 1.2-    , _maskHeight       = Percent 1.2-    , _maskContent      = []-    }---- | Define a `<clipPath>` tag.-data ClipPath = ClipPath-  { _clipPathDrawAttributes :: DrawAttributes-    -- | Maps to the `clipPathUnits` attribute-  , _clipPathUnits          :: CoordinateUnits-    -- | Maps to the content of the tree-  , _clipPathContent        :: [Tree]-  }-  deriving (Eq, Show)---- | Lenses for the ClipPath type.-makeClassy ''ClipPath--instance WithDrawAttributes ClipPath where-  drawAttr = clipPathDrawAttributes--instance WithDefaultSvg ClipPath where-  defaultSvg = ClipPath-    { _clipPathDrawAttributes = mempty-    , _clipPathUnits = CoordUserSpace-    , _clipPathContent = mempty-    }---- | Define a `<pattern>` tag.-data Pattern = Pattern-    { -- | Pattern drawing attributes.-      _patternDrawAttributes :: !DrawAttributes-      -- | Possible `viewBox`.-    , _patternViewBox  :: !(Maybe (Double, Double, Double, Double))-      -- | Width of the pattern tile, mapped to the-      -- `width` attribute-    , _patternWidth    :: !Number-      -- | Height of the pattern tile, mapped to the-      -- `height` attribute-    , _patternHeight   :: !Number-      -- | Pattern tile base, mapped to the `x` and-      -- `y` attributes.-    , _patternPos      :: !Point-      -- | Elements used in the pattern.-    , _patternElements :: ![Tree]-      -- | Define the cordinate system to use for-      -- the pattern. Mapped to the `patternUnits`-      -- attribute.-    , _patternUnit        :: !CoordinateUnits-      -- | Value of the "preserveAspectRatio" attribute-    , _patternAspectRatio :: !PreserveAspectRatio -    }-    deriving Show---- | Lenses for the Patter type.-makeClassy ''Pattern--instance WithDrawAttributes Pattern where-    drawAttr = patternDrawAttributes--instance WithDefaultSvg Pattern where-  defaultSvg = Pattern-    { _patternViewBox  = Nothing-    , _patternWidth    = Num 0-    , _patternHeight   = Num 0-    , _patternPos      = (Num 0, Num 0)-    , _patternElements = []-    , _patternUnit = CoordBoundingBox-    , _patternDrawAttributes = mempty-    , _patternAspectRatio = defaultSvg-    }---- | Sum types helping keeping track of all the namable--- elemens in a SVG document.-data Element-    = ElementLinearGradient LinearGradient-    | ElementRadialGradient RadialGradient-    | ElementMeshGradient   MeshGradient-    | ElementGeometry Tree-    | ElementPattern  Pattern-    | ElementMarker Marker-    | ElementMask Mask-    | ElementClipPath ClipPath-    deriving Show---- | Represent a full svg document with style,--- geometry and named elements.-data Document = Document-    { _viewBox          :: Maybe (Double, Double, Double, Double)-    , _width            :: Maybe Number-    , _height           :: Maybe Number-    , _elements         :: [Tree]-    , _definitions      :: M.Map String Element-    , _description      :: String-    , _styleRules       :: [CssRule]-    , _documentLocation :: FilePath-    }-    deriving Show---- | Lenses associated to a SVG document.-makeClassy ''Document---- | Calculate the document size in function of the--- different available attributes in the document.-documentSize :: Dpi -> Document -> (Int, Int)-documentSize _ Document { _viewBox = Just (x1, y1, x2, y2)-                        , _width = Just (Percent pw)-                        , _height = Just (Percent ph)-                        } =-    (floor $ dx * pw, floor $ dy * ph)-      where-        dx = abs $ x2 - x1-        dy = abs $ y2 - y1-documentSize _ Document { _width = Just (Num w)-                        , _height = Just (Num h) } = (floor w, floor h)-documentSize dpi doc@(Document { _width = Just w-                               , _height = Just h }) =-  documentSize dpi $ doc-    { _width = Just $ toUserUnit dpi w-    , _height = Just $ toUserUnit dpi h }-documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } =-    (floor . abs $ x2 - x1, floor . abs $ y2 - y1)-documentSize _ _ = (1, 1)--mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a-mayMerge (Just a) (Just b) = Just $ mappend a b-mayMerge _ b@(Just _) = b-mayMerge a Nothing = a--instance Monoid DrawAttributes where-    mempty = DrawAttributes-        { _strokeWidth      = Last Nothing-        , _strokeColor      = Last Nothing-        , _strokeOpacity    = Nothing-        , _strokeLineCap    = Last Nothing-        , _strokeLineJoin   = Last Nothing-        , _strokeMiterLimit = Last Nothing-        , _fillColor        = Last Nothing-        , _groupOpacity     = Nothing-        , _fillOpacity      = Nothing-        , _fontSize         = Last Nothing-        , _fontFamily       = Last Nothing-        , _fontStyle        = Last Nothing-        , _transform        = Nothing-        , _fillRule         = Last Nothing-        , _attrClass        = mempty-        , _attrId           = Nothing-        , _strokeOffset     = Last Nothing-        , _strokeDashArray  = Last Nothing-        , _textAnchor       = Last Nothing-        , _maskRef          = Last Nothing-        , _clipPathRef      = Last Nothing-        , _clipRule         = Last Nothing--        , _markerStart      = Last Nothing-        , _markerMid        = Last Nothing-        , _markerEnd        = Last Nothing-        }--    mappend a b = DrawAttributes-        { _strokeWidth = (mappend `on` _strokeWidth) a b-        , _strokeColor =  (mappend `on` _strokeColor) a b-        , _strokeLineCap = (mappend `on` _strokeLineCap) a b-        , _strokeOpacity = (opacityMappend `on` _strokeOpacity) a b-        , _strokeLineJoin = (mappend `on` _strokeLineJoin) a b-        , _strokeMiterLimit = (mappend `on` _strokeMiterLimit) a b-        , _fillColor =  (mappend `on` _fillColor) a b-        , _fillOpacity = (opacityMappend `on` _fillOpacity) a b-        , _fontSize = (mappend `on` _fontSize) a b-        , _transform = (mayMerge `on` _transform) a b-        , _fillRule = (mappend `on` _fillRule) a b-        , _attrClass = _attrClass b-        , _attrId = _attrId b-        , _groupOpacity = _groupOpacity b-        , _strokeOffset = (mappend `on` _strokeOffset) a b-        , _strokeDashArray = (mappend `on` _strokeDashArray) a b-        , _fontFamily = (mappend `on` _fontFamily) a b-        , _fontStyle = (mappend `on` _fontStyle) a b-        , _textAnchor = (mappend `on` _textAnchor) a b-        , _maskRef = (mappend `on` _maskRef) a b-        , _clipPathRef = (mappend `on` _clipPathRef) a b-        , _clipRule = (mappend `on` _clipRule) a b-        , _markerStart = (mappend `on` _markerStart) a b-        , _markerMid = (mappend `on` _markerMid) a b-        , _markerEnd = (mappend `on` _markerEnd) a b-        }-      where-        opacityMappend Nothing Nothing = Nothing-        opacityMappend (Just v) Nothing = Just v-        opacityMappend Nothing (Just v) = Just v-        opacityMappend (Just v) (Just v2) = Just $ v * v2--instance WithDefaultSvg DrawAttributes where-  defaultSvg = mempty--instance CssMatcheable Tree where-  cssAttribOf _ _ = Nothing-  cssClassOf = view (drawAttr . attrClass)-  cssIdOf = fmap T.pack . view (drawAttr . attrId)-  cssNameOf = nameOfTree-+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+-- | This module define all the types used in the definition
+-- of a svg scene.
+--
+-- Most of the types are lensified.
+module Graphics.Svg.Types
+    ( -- * Basic building types
+      Coord
+    , Origin( .. )
+    , Point
+    , RPoint
+    , PathCommand( .. )
+    , Transformation( .. )
+    , ElementRef( .. )
+    , CoordinateUnits( .. )
+
+      -- ** Building helpers
+    , toPoint
+    , serializeNumber
+    , serializeTransformation
+    , serializeTransformations
+
+      -- * Drawing control types
+    , Cap( .. )
+    , LineJoin( .. )
+    , Tree( .. )
+    , Number( .. )
+    , Spread( .. )
+    , Texture( .. )
+    , Element( .. )
+    , FillRule( .. )
+    , FontStyle( .. )
+    , Dpi
+
+    , WithDefaultSvg( .. )
+
+      -- * Main type
+    , Document( .. )
+    , HasDocument( .. )
+    , documentSize
+
+      -- * Drawing attributes
+    , DrawAttributes( .. )
+    , HasDrawAttributes( .. )
+    , WithDrawAttributes( .. )
+
+      -- * SVG drawing primitives
+      -- ** Rectangle
+    , Rectangle( .. )
+    , HasRectangle( .. )
+
+      -- ** Line
+    , Line( .. )
+    , HasLine( .. )
+
+      -- ** Polygon
+    , Polygon( .. )
+    , HasPolygon( .. )
+
+      -- ** Polyline
+    , PolyLine( .. )
+    , HasPolyLine( .. )
+
+      -- ** Path
+    , Path( .. )
+    , HasPath( .. )
+
+      -- ** Circle
+    , Circle( .. )
+    , HasCircle( .. )
+
+      -- ** Ellipse
+    , Ellipse( .. )
+    , HasEllipse( .. )
+
+      -- ** Mesh (gradient mesh)
+    , GradientPathCommand( .. )
+    , MeshGradientType( .. )
+
+    , MeshGradient( .. )
+    , HasMeshGradient( .. )
+
+    , MeshGradientRow( .. )
+    , HasMeshGradientRow( .. )
+
+    , MeshGradientPatch( .. )
+    , HasMeshGradientPatch( .. )
+
+      -- ** Image
+    , Image( .. )
+    , HasImage( .. )
+
+      -- ** Use
+    , Use( .. )
+    , HasUse( .. )
+
+      -- * Grouping primitives
+      -- ** Group
+    , Group( .. )
+    , HasGroup( .. )
+
+      -- ** Symbol
+    , Symbol( .. )
+    , groupOfSymbol
+
+      -- * Text related types
+      -- ** Text
+    , Text( .. )
+    , HasText( .. )
+    , TextAnchor( .. )
+    , textAt
+
+      -- ** Text path
+    , TextPath( .. )
+    , HasTextPath( .. )
+
+    , TextPathSpacing( .. )
+    , TextPathMethod( .. )
+
+      -- ** Text span.
+    , TextSpanContent( .. )
+
+    , TextSpan( .. )
+    , HasTextSpan( .. )
+
+    , TextInfo( .. )
+    , HasTextInfo( .. )
+
+    , TextAdjust( .. )
+
+      -- * Marker definition
+    , Marker( .. )
+    , Overflow( .. )
+    , MarkerOrientation( .. )
+    , MarkerUnit( .. )
+    , HasMarker( .. )
+
+      -- * Gradient definition
+    , GradientStop( .. )
+    , HasGradientStop( .. )
+
+      -- ** Linear Gradient
+    , LinearGradient( .. )
+    , HasLinearGradient( .. )
+
+      -- ** Radial Gradient
+    , RadialGradient( .. )
+    , HasRadialGradient( .. )
+
+      -- * Pattern definition
+    , Pattern( .. )
+    , HasPattern( .. )
+
+      -- * Mask definition
+    , Mask( .. )
+    , HasMask( .. )
+
+      -- * Clip path definition
+    , ClipPath( .. )
+    , HasClipPath( .. )
+
+      -- * Aspect Ratio description
+    , PreserveAspectRatio( .. )
+    , Alignment( .. )
+    , MeetSlice( .. )
+    , HasPreserveAspectRatio( .. )
+
+      -- * MISC functions
+    , isPathArc
+    , isPathWithArc
+    , nameOfTree
+    , zipTree
+    , mapTree
+    , foldTree
+    , toUserUnit
+    , mapNumber
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( Monoid( .. ) )
+import Data.Foldable( Foldable )
+#endif
+
+import Data.Function( on )
+import Data.List( inits )
+import qualified Data.Map as M
+import Data.Monoid( Last( .. ), (<>) )
+import qualified Data.Foldable as F
+import qualified Data.Text as T
+import Codec.Picture( PixelRGBA8( .. ) )
+import Control.Lens( Lens'
+                   , lens
+                   , makeClassy
+                   , makeLenses
+                   , view
+                   , (^.)
+                   , (&)
+                   , (.~)
+                   )
+import Graphics.Svg.CssTypes
+import Linear hiding ( angle )
+
+import Text.Printf
+
+-- | Basic coordiante type.
+type Coord = Double
+
+-- | Real Point, fully determined and not
+-- dependant of the rendering context.
+type RPoint = V2 Coord
+
+-- | Possibly context dependant point.
+type Point = (Number, Number)
+
+-- | Tell if a path command is absolute (in the current
+-- user coordiante) or relative to the previous poitn.
+data Origin
+  = OriginAbsolute -- ^ Next point in absolute coordinate
+  | OriginRelative -- ^ Next point relative to the previous
+  deriving (Eq, Show)
+
+data MeshGradientType
+  = GradientBilinear
+  | GradientBicubic
+  deriving (Eq, Show)
+
+-- | Path command definition.
+data PathCommand
+      -- | 'M' or 'm' command
+    = MoveTo !Origin ![RPoint]
+      -- | Line to, 'L' or 'l' Svg path command.
+    | LineTo !Origin ![RPoint]
+
+      -- | Equivalent to the 'H' or 'h' svg path command.
+    | HorizontalTo  !Origin ![Coord]
+      -- | Equivalent to the 'V' or 'v' svg path command.
+    | VerticalTo    !Origin ![Coord]
+
+    -- | Cubic bezier, 'C' or 'c' command
+    | CurveTo  !Origin ![(RPoint, RPoint, RPoint)]
+    -- | Smooth cubic bezier, equivalent to 'S' or 's' command
+    | SmoothCurveTo  !Origin ![(RPoint, RPoint)]
+    -- | Quadratic bezier, 'Q' or 'q' command
+    | QuadraticBezier !Origin ![(RPoint, RPoint)]
+    -- | Quadratic bezier, 'T' or 't' command
+    | SmoothQuadraticBezierCurveTo  !Origin ![RPoint]
+      -- | Eliptical arc, 'A' or 'a' command.
+    | EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)]
+      -- | Close the path, 'Z' or 'z' svg path command.
+    | EndPath
+    deriving (Eq, Show)
+
+-- | Description of path used in meshgradient tag
+data GradientPathCommand
+      -- | Line to, 'L' or 'l' Svg path command.
+    = GLine !Origin !(Maybe RPoint)
+      -- | Cubic bezier, 'C' or 'c' command
+    | GCurve !Origin !RPoint !RPoint !(Maybe RPoint)
+      -- | 'Z' command
+    | GClose
+    deriving (Eq, Show)
+
+-- | Little helper function to build a point.
+toPoint :: Number -> Number -> Point
+toPoint = (,)
+
+-- | Tell if the path command is an EllipticalArc.
+isPathArc :: PathCommand -> Bool
+isPathArc (EllipticalArc _ _) = True
+isPathArc _ = False
+
+-- | Tell if a full path contain an EllipticalArc.
+isPathWithArc :: Foldable f => f PathCommand -> Bool
+isPathWithArc = F.any isPathArc
+
+-- | Define the possible values of various *units attributes
+-- used in the definition of the gradients and masks.
+data CoordinateUnits
+    = CoordUserSpace   -- ^ `userSpaceOnUse` value
+    | CoordBoundingBox -- ^ `objectBoundingBox` value
+    deriving (Eq, Show)
+
+-- | This type represent the align information of the
+-- preserveAspectRatio SVGattribute
+data Alignment
+  = AlignNone -- ^ "none" value
+  | AlignxMinYMin -- "xMinYMin" value
+  | AlignxMidYMin -- ^ "xMidYMin" value
+  | AlignxMaxYMin -- ^ "xMaxYMin" value
+  | AlignxMinYMid -- ^ "xMinYMid" value
+  | AlignxMidYMid -- ^ "xMidYMid" value
+  | AlignxMaxYMid -- ^ "xMaxYMid" value
+  | AlignxMinYMax -- ^ "xMinYMax" value
+  | AlignxMidYMax -- ^ "xMidYMax" value
+  | AlignxMaxYMax -- ^ "xMaxYMax" value
+  deriving (Eq, Show)
+
+-- | This type represent the "meet or slice" information
+-- of the preserveAspectRatio SVGattribute
+data MeetSlice = Meet | Slice
+    deriving (Eq, Show)
+
+-- | Describe the content of the preserveAspectRatio attribute.
+data PreserveAspectRatio = PreserveAspectRatio
+  { _aspectRatioDefer     :: !Bool
+  , _aspectRatioAlign     :: !Alignment
+  , _aspectRatioMeetSlice :: !(Maybe MeetSlice)
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the PreserveAspectRatio type
+makeClassy ''PreserveAspectRatio 
+
+instance WithDefaultSvg PreserveAspectRatio where
+  defaultSvg = PreserveAspectRatio 
+    { _aspectRatioDefer     = False
+    , _aspectRatioAlign     = AlignxMidYMid
+    , _aspectRatioMeetSlice = Nothing
+    }
+
+-- | Describe how the line should be terminated
+-- when stroking them. Describe the values of the
+-- `stroke-linecap` attribute.
+-- See `_strokeLineCap`
+data Cap
+  = CapRound -- ^ End with a round (`round` value)
+  | CapButt  -- ^ Define straight just at the end (`butt` value)
+  | CapSquare -- ^ Straight further of the ends (`square` value)
+  deriving (Eq, Show)
+
+-- | Define the possible values of the `stroke-linejoin`
+-- attribute.
+-- see `_strokeLineJoin`
+data LineJoin
+    = JoinMiter -- ^ `miter` value
+    | JoinBevel -- ^ `bevel` value
+    | JoinRound -- ^ `round` value
+    deriving (Eq, Show)
+
+-- | Describe the different value which can be used
+-- in the `fill` or `stroke` attributes.
+data Texture
+  = ColorRef   PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb)
+  | TextureRef String     -- ^ Link to a complex texture (url(#name))
+  | FillNone              -- ^ Equivalent to the `none` value.
+  deriving (Eq, Show)
+
+-- | Describe the possile filling algorithms.
+-- Map the values of the `fill-rule` attributes.
+data FillRule
+    = FillEvenOdd -- ^ Correspond to the `evenodd` value.
+    | FillNonZero -- ^ Correspond to the `nonzero` value.
+    deriving (Eq, Show)
+
+-- | Describe the content of the `transformation` attribute.
+-- see `_transform` and `transform`.
+data Transformation
+    = -- | Directly encode the translation matrix.
+      TransformMatrix !Coord !Coord !Coord
+                      !Coord !Coord !Coord
+      -- | Translation along a vector
+    | Translate !Double !Double
+      -- | Scaling on both axis or on X axis and Y axis.
+    | Scale !Double !(Maybe Double)
+      -- | Rotation around `(0, 0)` or around an optional
+      -- point.
+    | Rotate !Double !(Maybe (Double, Double))
+      -- | Skew transformation along the X axis.
+    | SkewX !Double
+      -- | Skew transformation along the Y axis.
+    | SkewY !Double
+      -- | Unkown transformation, like identity.
+    | TransformUnknown
+    deriving (Eq, Show)
+
+-- | Convert the Transformation to a string which can be
+-- directly used in a svg attributes.
+serializeTransformation :: Transformation -> String
+serializeTransformation t = case t of
+  TransformUnknown -> ""
+  TransformMatrix a b c d e f ->
+      printf "matrix(%g, %g, %g, %g, %g, %g)" a b c d e f
+  Translate x y -> printf "translate(%g, %g)" x y
+  Scale x Nothing -> printf "scale(%g)" x
+  Scale x (Just y) -> printf "scale(%g, %g)" x y
+  Rotate angle Nothing -> printf "rotate(%g)" angle
+  Rotate angle (Just (x, y))-> printf "rotate(%g, %g, %g)" angle x y
+  SkewX x -> printf "skewX(%g)" x
+  SkewY y -> printf "skewY(%g)" y
+
+-- | Transform a list of transformations to a string for svg
+-- `transform` attributes.
+serializeTransformations :: [Transformation] -> String
+serializeTransformations =
+    unwords . fmap serializeTransformation
+
+-- | Class helping find the drawing attributes for all
+-- the SVG attributes.
+class WithDrawAttributes a where
+    -- | Lens which can be used to read/write primitives.
+    drawAttr :: Lens' a DrawAttributes
+
+-- | Define an empty 'default' element for the SVG tree.
+-- It is used as base when parsing the element from XML.
+class WithDefaultSvg a where
+    -- | The default element.
+    defaultSvg :: a
+
+-- | Classify the font style, used to search a matching
+-- font in the FontCache.
+data FontStyle
+  = FontStyleNormal
+  | FontStyleItalic
+  | FontStyleOblique
+  deriving (Eq, Show)
+
+-- | Tell where to anchor the text, where the position
+-- given is realative to the text.
+data TextAnchor
+    -- | The text with left aligned, or start at the postion
+    -- If the point is the '*' then the text will be printed
+    -- this way:
+    --
+    -- >  *THE_TEXT_TO_PRINT
+    --
+    -- Equivalent to the `start` value.
+  = TextAnchorStart
+    -- | The text is middle aligned, so the text will be at
+    -- the left and right of the position:
+    --
+    -- >   THE_TEXT*TO_PRINT
+    --
+    -- Equivalent to the `middle` value.
+  | TextAnchorMiddle
+    -- | The text is right aligned.
+    --
+    -- >   THE_TEXT_TO_PRINT*
+    --
+    -- Equivalent to the `end` value.
+  | TextAnchorEnd
+  deriving (Eq, Show)
+
+
+-- | Correspond to the possible values of the
+-- the attributes which are either `none` or
+-- `url(#elem)`
+data ElementRef
+  = RefNone  -- ^ Value for `none`
+  | Ref String -- ^ Equivalent to `url()` attribute.
+  deriving (Eq, Show)
+
+-- | This type define how to draw any primitives,
+-- which color to use, how to stroke the primitives
+-- and the potential transformations to use.
+--
+-- All these attributes are propagated to the children.
+data DrawAttributes = DrawAttributes
+    { -- | Attribute corresponding to the `stroke-width`
+      -- SVG attribute.
+      _strokeWidth      :: !(Last Number)
+      -- | Correspond to the `stroke` attribute.
+    , _strokeColor      :: !(Last Texture)
+      -- | Define the `stroke-opacity` attribute, the transparency
+      -- for the "border".
+    , _strokeOpacity    :: !(Maybe Float)
+      -- | Correspond to the `stroke-linecap` SVG
+      -- attribute
+    , _strokeLineCap    :: !(Last Cap)
+      -- | Correspond to the `stroke-linejoin` SVG
+      -- attribute
+    , _strokeLineJoin   :: !(Last LineJoin)
+      -- | Define the distance of the miter join, correspond
+      -- to the `stroke-miterlimit` attritbue.
+    , _strokeMiterLimit :: !(Last Double)
+      -- | Define the filling color of the elements. Corresponding
+      -- to the `fill` attribute.
+    , _fillColor        :: !(Last Texture)
+      -- | Define the `fill-opacity` attribute, the transparency
+      -- for the "content".
+    , _fillOpacity      :: !(Maybe Float)
+      -- | Define the global or group opacity attribute.
+    , _groupOpacity     :: !(Maybe Float)
+      -- | Content of the `transform` attribute
+    , _transform        :: !(Maybe [Transformation])
+      -- | Define the `fill-rule` used during the rendering.
+    , _fillRule         :: !(Last FillRule)
+      -- | Define the `mask` attribute.
+    , _maskRef          :: !(Last ElementRef)
+      -- | Define the `clip-path` attribute.
+    , _clipPathRef      :: !(Last ElementRef)
+      -- | Define the `clip-rule` attribute.
+    , _clipRule         :: !(Last FillRule)
+      -- | Map to the `class` attribute. Used for the CSS
+      -- rewriting.
+    , _attrClass        :: ![T.Text]
+      -- | Map to the `id` attribute. Used for the CSS
+      -- rewriting.
+    , _attrId           :: !(Maybe String)
+      -- | Define the start distance of the dashing pattern.
+      -- Correspond to the `stroke-dashoffset` attribute.
+    , _strokeOffset     :: !(Last Number)
+      -- | Define the dashing pattern for the lines. Correspond
+      -- to the `stroke-dasharray` attribute.
+    , _strokeDashArray  :: !(Last [Number])
+      -- | Current size of the text, correspond to the
+      -- `font-size` SVG attribute.
+    , _fontSize         :: !(Last Number)
+      -- | Define the possible fonts to be used for text rendering.
+      -- Map to the `font-family` attribute.
+    , _fontFamily       :: !(Last [String])
+      -- | Map to the `font-style` attribute.
+    , _fontStyle        :: !(Last FontStyle)
+      -- | Define how to interpret the text position, correspond
+      -- to the `text-anchor` attribute.
+    , _textAnchor       :: !(Last TextAnchor)
+      -- | Define the marker used for the start of the line.
+      -- Correspond to the `marker-start` attribute.
+    , _markerStart      :: !(Last ElementRef)
+      -- | Define the marker used for every point of the
+      -- polyline/path Correspond to the `marker-mid`
+      -- attribute.
+    , _markerMid        :: !(Last ElementRef)
+      -- | Define the marker used for the end of the line.
+      -- Correspond to the `marker-end` attribute.
+    , _markerEnd        :: !(Last ElementRef)
+    }
+    deriving (Eq, Show)
+
+-- | Lenses for the DrawAttributes type.
+makeClassy ''DrawAttributes
+
+-- | This primitive describe an unclosed suite of
+-- segments. Correspond to the `<polyline>` tag.
+data PolyLine = PolyLine
+  { -- | drawing attributes of the polyline.
+    _polyLineDrawAttributes :: !DrawAttributes
+
+    -- | Geometry definition of the polyline.
+    -- correspond to the `points` attribute
+  , _polyLinePoints :: ![RPoint]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the PolyLine type.
+makeClassy ''PolyLine
+
+instance WithDefaultSvg PolyLine where
+  defaultSvg = PolyLine
+    { _polyLineDrawAttributes = mempty
+    , _polyLinePoints = []
+    }
+
+
+instance WithDrawAttributes PolyLine where
+    drawAttr = polyLineDrawAttributes
+
+-- | Primitive decriving polygon composed
+-- of segements. Correspond to the `<polygon>`
+-- tag
+data Polygon = Polygon
+  { -- | Drawing attributes for the polygon.
+    _polygonDrawAttributes :: !DrawAttributes
+    -- | Points of the polygon. Correspond to
+    -- the `points` attributes.
+  , _polygonPoints :: ![RPoint]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Polygon type
+makeClassy ''Polygon
+
+instance WithDrawAttributes Polygon where
+    drawAttr = polygonDrawAttributes
+
+instance WithDefaultSvg Polygon where
+  defaultSvg = Polygon
+    { _polygonDrawAttributes = mempty
+    , _polygonPoints = []
+    }
+
+-- | Define a simple line. Correspond to the
+-- `<line>` tag.
+data Line = Line
+  { -- | Drawing attributes of line.
+    _lineDrawAttributes :: !DrawAttributes
+    -- | First point of the the line, correspond
+    -- to the `x1` and `y1` attributes.
+  , _linePoint1 :: !Point
+    -- | Second point of the the line, correspond
+    -- to the `x2` and `y2` attributes.
+  , _linePoint2 :: !Point
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Line type.
+makeClassy ''Line
+
+instance WithDrawAttributes Line where
+    drawAttr = lineDrawAttributes
+
+instance WithDefaultSvg Line where
+  defaultSvg = Line
+    { _lineDrawAttributes = mempty
+    , _linePoint1 = zeroPoint
+    , _linePoint2 = zeroPoint
+    }
+    where zeroPoint = (Num 0, Num 0)
+
+-- | Define a rectangle. Correspond to
+-- `<rectangle>` svg tag.
+data Rectangle = Rectangle
+  { -- | Rectangle drawing attributes.
+    _rectDrawAttributes  :: !DrawAttributes
+    -- | Upper left corner of the rectangle, correspond
+    -- to the attributes `x` and `y`.
+  , _rectUpperLeftCorner :: !Point
+    -- | Rectangle width, correspond, strangely, to
+    -- the `width` attribute.
+  , _rectWidth           :: !Number
+    -- | Rectangle height, correspond, amazingly, to
+    -- the `height` attribute.
+  , _rectHeight          :: !Number
+    -- | Define the rounded corner radius radius
+    -- of the rectangle. Correspond to the `rx` and
+    -- `ry` attributes.
+  , _rectCornerRadius    :: !(Number, Number)
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Rectangle type.
+makeClassy ''Rectangle
+
+instance WithDrawAttributes Rectangle where
+    drawAttr = rectDrawAttributes
+
+instance WithDefaultSvg Rectangle where
+  defaultSvg = Rectangle
+    { _rectDrawAttributes  = mempty
+    , _rectUpperLeftCorner = (Num 0, Num 0)
+    , _rectWidth           = Num 0
+    , _rectHeight          = Num 0
+    , _rectCornerRadius    = (Num 0, Num 0)
+    }
+
+-- | Type mapping the `<path>` svg tag.
+data Path = Path
+  { -- | Drawing attributes of the path.
+    _pathDrawAttributes :: !DrawAttributes
+    -- | Definition of the path, correspond to the
+    -- `d` attributes.
+  , _pathDefinition :: ![PathCommand]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Path type
+makeClassy ''Path
+
+instance WithDrawAttributes Path where
+  drawAttr = pathDrawAttributes
+
+instance WithDefaultSvg Path where
+  defaultSvg = Path
+    { _pathDrawAttributes = mempty
+    , _pathDefinition = []
+    }
+
+-- | Define a SVG group, corresponding `<g>` tag.
+data Group a = Group
+  { -- | Group drawing attributes, propagated to all of its
+    -- children.
+    _groupDrawAttributes :: !DrawAttributes
+    -- | Content of the group, corresponding to all the tags
+    -- inside the `<g>` tag.
+  , _groupChildren  :: ![a]
+    -- | Mapped to the attribute `viewBox`
+  , _groupViewBox   :: !(Maybe (Double, Double, Double, Double))
+    -- | used for symbols only
+  , _groupAspectRatio :: !PreserveAspectRatio
+  }
+  deriving (Eq, Show)
+
+-- | Lenses associated to the Group type.
+makeClassy ''Group
+
+instance WithDrawAttributes (Group a) where
+    drawAttr = groupDrawAttributes
+
+instance WithDefaultSvg (Group a) where
+  defaultSvg = Group
+    { _groupDrawAttributes = mempty
+    , _groupChildren  = []
+    , _groupViewBox = Nothing
+    , _groupAspectRatio = defaultSvg
+    }
+
+-- | Define the `<symbol>` tag, equivalent to
+-- a named group.
+newtype Symbol a =
+    Symbol { _groupOfSymbol :: Group a }
+  deriving (Eq, Show)
+
+-- | Lenses associated with the Symbol type.
+makeLenses ''Symbol
+
+instance WithDrawAttributes (Symbol a) where
+  drawAttr = groupOfSymbol . drawAttr
+
+instance WithDefaultSvg (Symbol a) where
+  defaultSvg = Symbol defaultSvg
+
+-- | Define a `<circle>`.
+data Circle = Circle
+  { -- | Drawing attributes of the circle.
+    _circleDrawAttributes :: !DrawAttributes
+    -- | Define the center of the circle, describe
+    -- the `cx` and `cy` attributes.
+  , _circleCenter   :: !Point
+    -- | Radius of the circle, equivalent to the `r`
+    -- attribute.
+  , _circleRadius   :: !Number
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Circle type.
+makeClassy ''Circle
+
+instance WithDrawAttributes Circle where
+    drawAttr = circleDrawAttributes
+
+instance WithDefaultSvg Circle where
+  defaultSvg = Circle
+    { _circleDrawAttributes = mempty
+    , _circleCenter = (Num 0, Num 0)
+    , _circleRadius = Num 0
+    }
+
+-- | Define an `<ellipse>`
+data Ellipse = Ellipse
+  {  -- | Drawing attributes of the ellipse.
+    _ellipseDrawAttributes :: !DrawAttributes
+    -- | Center of the ellipse, map to the `cx`
+    -- and `cy` attributes.
+  , _ellipseCenter :: !Point
+    -- | Radius along the X axis, map the
+    -- `rx` attribute.
+  , _ellipseXRadius :: !Number
+    -- | Radius along the Y axis, map the
+    -- `ry` attribute.
+  , _ellipseYRadius :: !Number
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the ellipse type.
+makeClassy ''Ellipse
+
+instance WithDrawAttributes Ellipse where
+  drawAttr = ellipseDrawAttributes
+
+instance WithDefaultSvg Ellipse where
+  defaultSvg = Ellipse
+    { _ellipseDrawAttributes = mempty
+    , _ellipseCenter = (Num 0, Num 0)
+    , _ellipseXRadius = Num 0
+    , _ellipseYRadius = Num 0
+    }
+
+-- | Define a color stop for the gradients. Represent
+-- the `<stop>` SVG tag.
+data GradientStop = GradientStop
+    { -- | Gradient offset between 0 and 1, correspond
+      -- to the `offset` attribute.
+      _gradientOffset :: !Float
+      -- | Color of the gradient stop. Correspond
+      -- to the `stop-color` attribute.
+    , _gradientColor  :: !PixelRGBA8
+      -- | Path command used in mesh patch
+    , _gradientPath   :: !(Maybe GradientPathCommand)
+      -- | Stop color opacity
+    , _gradientOpacity :: !(Maybe Float)
+    }
+    deriving (Eq, Show)
+
+-- | Lenses for the GradientStop type.
+makeClassy ''GradientStop
+
+instance WithDefaultSvg GradientStop where
+  defaultSvg = GradientStop
+    { _gradientOffset = 0.0
+    , _gradientColor  = PixelRGBA8 0 0 0 255
+    , _gradientPath   = Nothing
+    , _gradientOpacity = Nothing
+    }
+
+
+-- | Define `<meshpatch>` SVG tag
+data MeshGradientPatch = MeshGradientPatch
+  { -- | List of stop, from 2 to 4 in a patch
+    _meshGradientPatchStops :: ![GradientStop]
+  }
+  deriving (Eq, Show)
+
+makeClassy ''MeshGradientPatch
+
+instance WithDefaultSvg MeshGradientPatch where
+  defaultSvg = MeshGradientPatch []
+
+-- | Define a `<meshrow>` tag.
+data MeshGradientRow = MeshGradientRow
+  { -- | List of patch in a row
+    _meshGradientRowPatches :: ![MeshGradientPatch]
+  }
+  deriving (Eq, Show)
+
+makeClassy ''MeshGradientRow
+
+instance WithDefaultSvg MeshGradientRow where
+  defaultSvg = MeshGradientRow []
+
+
+-- | Define a `<meshgradient>` tag.
+data MeshGradient = MeshGradient
+  { _meshGradientDrawAttributes :: !DrawAttributes
+    -- | Original x coordinate of the mesh gradient
+  , _meshGradientX              :: !Number
+    -- | Original y coordinate of the mesh gradient
+  , _meshGradientY              :: !Number
+    -- | Type of color interpolation to use
+  , _meshGradientType           :: !MeshGradientType
+    -- | Coordiante system to use
+  , _meshGradientUnits          :: !CoordinateUnits
+    -- | Optional transform
+  , _meshGradientTransform      :: ![Transformation]
+    -- | List of patch rows in the the mesh.
+  , _meshGradientRows           :: ![MeshGradientRow]
+  }
+  deriving (Eq, Show)
+
+makeClassy ''MeshGradient
+
+instance WithDrawAttributes MeshGradient where
+  drawAttr = meshGradientDrawAttributes
+
+instance WithDefaultSvg MeshGradient where
+  defaultSvg = MeshGradient
+    { _meshGradientDrawAttributes = mempty
+    , _meshGradientX              = Percent 0
+    , _meshGradientY              = Percent 0
+    , _meshGradientType           = GradientBilinear
+    , _meshGradientUnits          = CoordBoundingBox
+    , _meshGradientTransform      = mempty
+    , _meshGradientRows           = mempty
+    }
+
+
+-- | Define an `<image>` tag.
+data Image = Image
+  { -- | Drawing attributes of the image
+    _imageDrawAttributes :: !DrawAttributes
+    -- | Position of the image referenced by its
+    -- upper left corner.
+  , _imageCornerUpperLeft :: !Point
+    -- | Image width
+  , _imageWidth :: !Number
+    -- | Image Height
+  , _imageHeight :: !Number
+    -- | Image href, pointing to the real image.
+  , _imageHref :: !String
+    -- | preserveAspectRatio attribute
+  , _imageAspectRatio :: !PreserveAspectRatio
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Image type.
+makeClassy ''Image
+
+instance WithDrawAttributes Image where
+  drawAttr = imageDrawAttributes
+
+instance WithDefaultSvg Image where
+  defaultSvg = Image
+    { _imageDrawAttributes = mempty
+    , _imageCornerUpperLeft = (Num 0, Num 0)
+    , _imageWidth = Num 0
+    , _imageHeight = Num 0
+    , _imageHref = ""
+    , _imageAspectRatio = defaultSvg
+    }
+
+-- | Define an `<use>` for a named content.
+-- Every named content can be reused in the
+-- document using this element.
+data Use = Use
+  { -- | Position where to draw the "used" element.
+    -- Correspond to the `x` and `y` attributes.
+    _useBase   :: Point
+    -- | Referenced name, correspond to `xlink:href`
+    -- attribute.
+  , _useName   :: String
+    -- | Define the width of the region where
+    -- to place the element. Map to the `width`
+    -- attribute.
+  , _useWidth  :: Maybe Number
+    -- | Define the height of the region where
+    -- to place the element. Map to the `height`
+    -- attribute.
+  , _useHeight :: Maybe Number
+    -- | Use draw attributes.
+  , _useDrawAttributes :: DrawAttributes
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Use type.
+makeClassy ''Use
+
+instance WithDrawAttributes Use where
+  drawAttr = useDrawAttributes
+
+instance WithDefaultSvg Use where
+  defaultSvg = Use
+    { _useBase   = (Num 0, Num 0)
+    , _useName   = ""
+    , _useWidth  = Nothing
+    , _useHeight = Nothing
+    , _useDrawAttributes = mempty
+    }
+
+-- | Define position information associated to
+-- `<text>` or `<tspan>` svg tag.
+data TextInfo = TextInfo
+  { _textInfoX      :: ![Number] -- ^ `x` attribute.
+  , _textInfoY      :: ![Number] -- ^ `y` attribute.
+  , _textInfoDX     :: ![Number] -- ^ `dx` attribute.
+  , _textInfoDY     :: ![Number] -- ^ `dy` attribute.
+  , _textInfoRotate :: ![Double] -- ^ `rotate` attribute.
+  , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute.
+  }
+  deriving (Eq, Show)
+
+instance Monoid TextInfo where
+  mempty = TextInfo [] [] [] [] [] Nothing
+  mappend (TextInfo x1 y1 dx1 dy1 r1 l1)
+          (TextInfo x2 y2 dx2 dy2 r2 l2) =
+    TextInfo (x1 <> x2)   (y1 <> y2)
+                (dx1 <> dx2) (dy1 <> dy2)
+                (r1 <> r2)
+                (getLast $ Last l1 <> Last l2)
+
+-- | Lenses for the TextInfo type.
+makeClassy ''TextInfo
+
+instance WithDefaultSvg TextInfo where
+  defaultSvg = mempty
+
+-- | Define the content of a `<tspan>` tag.
+data TextSpanContent
+    = SpanText    !T.Text -- ^ Raw text
+    | SpanTextRef !String -- ^ Equivalent to a `<tref>`
+    | SpanSub     !TextSpan -- ^ Define a `<tspan>`
+    deriving (Eq, Show)
+
+-- | Define a `<tspan>` tag.
+data TextSpan = TextSpan
+  { -- | Placing information for the text.
+    _spanInfo           :: !TextInfo
+    -- | Drawing attributes for the text span.
+  , _spanDrawAttributes :: !DrawAttributes
+    -- | Content of the span.
+  , _spanContent        :: ![TextSpanContent]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the TextSpan type.
+makeClassy ''TextSpan
+
+instance WithDefaultSvg TextSpan where
+  defaultSvg = TextSpan
+    { _spanInfo = defaultSvg
+    , _spanDrawAttributes = mempty
+    , _spanContent        = mempty
+    }
+
+-- | Describe the content of the `method` attribute on
+-- text path.
+data TextPathMethod
+  = TextPathAlign   -- ^ Map to the `align` value.
+  | TextPathStretch -- ^ Map to the `stretch` value.
+  deriving (Eq, Show)
+
+-- | Describe the content of the `spacing` text path
+-- attribute.
+data TextPathSpacing
+  = TextPathSpacingExact -- ^ Map to the `exact` value.
+  | TextPathSpacingAuto  -- ^ Map to the `auto` value.
+  deriving (Eq, Show)
+
+-- | Describe the `<textpath>` SVG tag.
+data TextPath = TextPath
+  { -- | Define the beginning offset on the path,
+    -- the `startOffset` attribute.
+    _textPathStartOffset :: !Number
+    -- | Define the `xlink:href` attribute.
+  , _textPathName        :: !String
+    -- | Correspond to the `method` attribute.
+  , _textPathMethod      :: !TextPathMethod
+    -- | Correspond to the `spacing` attribute.
+  , _textPathSpacing     :: !TextPathSpacing
+    -- | Real content of the path.
+  , _textPathData        :: ![PathCommand]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the TextPath type.
+makeClassy ''TextPath
+
+instance WithDefaultSvg TextPath where
+  defaultSvg = TextPath
+    { _textPathStartOffset = Num 0
+    , _textPathName        = mempty
+    , _textPathMethod      = TextPathAlign
+    , _textPathSpacing     = TextPathSpacingExact
+    , _textPathData        = []
+    }
+
+-- | Define the possible values of the `lengthAdjust`
+-- attribute.
+data TextAdjust
+  = TextAdjustSpacing -- ^ Value `spacing`
+  | TextAdjustSpacingAndGlyphs -- ^ Value `spacingAndGlyphs`
+  deriving (Eq, Show)
+
+-- | Define the global `<tag>` SVG tag.
+data Text = Text
+  { -- | Define the `lengthAdjust` attribute.
+    _textAdjust   :: !TextAdjust
+    -- | Root of the text content.
+  , _textRoot     :: !TextSpan
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Text type.
+makeClassy ''Text
+
+-- | Little helper to create a SVG text at a given
+-- baseline position.
+textAt :: Point -> T.Text -> Text
+textAt (x, y) txt = Text TextAdjustSpacing tspan where
+  tspan = defaultSvg
+        { _spanContent = [SpanText txt]
+        , _spanInfo = defaultSvg
+                    { _textInfoX = [x]
+                    , _textInfoY = [y]
+                    }
+        }
+
+instance WithDrawAttributes Text where
+  drawAttr = textRoot . spanDrawAttributes
+
+instance WithDefaultSvg Text where
+  defaultSvg = Text
+    { _textRoot = defaultSvg
+    , _textAdjust = TextAdjustSpacing
+    }
+
+-- | Main type for the scene description, reorient to
+-- specific type describing each tag.
+data Tree
+    = None
+    | UseTree { useInformation :: !Use
+              , useSubTree     :: !(Maybe Tree) }
+    | GroupTree     !(Group Tree)
+    | SymbolTree    !(Symbol Tree)
+    | PathTree      !Path
+    | CircleTree    !Circle
+    | PolyLineTree  !PolyLine
+    | PolygonTree   !Polygon
+    | EllipseTree   !Ellipse
+    | LineTree      !Line
+    | RectangleTree !Rectangle
+    | TextTree      !(Maybe TextPath) !Text
+    | ImageTree     !Image
+    | MeshGradientTree !MeshGradient
+    deriving (Eq, Show)
+
+-- | Define the orientation, associated to the
+-- `orient` attribute on the Marker
+data MarkerOrientation
+  = OrientationAuto        -- ^ Auto value
+  | OrientationAngle Coord -- ^ Specific angle.
+  deriving (Eq, Show)
+
+-- | Define the content of the `markerUnits` attribute
+-- on the Marker.
+data MarkerUnit
+  = MarkerUnitStrokeWidth    -- ^ Value `strokeWidth`
+  | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse`
+  deriving (Eq, Show)
+
+-- | Define the content of the `markerUnits` attribute
+-- on the Marker.
+data Overflow
+  = OverflowVisible    -- ^ Value `visible`
+  | OverflowHidden     -- ^ Value `hidden`
+  deriving (Eq, Show)
+
+-- | Define the `<marker>` tag.
+data Marker = Marker
+  { -- | Draw attributes of the marker.
+    _markerDrawAttributes :: DrawAttributes
+    -- | Define the reference point of the marker.
+    -- correspond to the `refX` and `refY` attributes.
+  , _markerRefPoint    :: !(Number, Number)
+    -- | Define the width of the marker. Correspond to
+    -- the `markerWidth` attribute.
+  , _markerWidth       :: !(Maybe Number)
+    -- | Define the height of the marker. Correspond to
+    -- the `markerHeight` attribute.
+  , _markerHeight      :: !(Maybe Number)
+    -- | Correspond to the `orient` attribute.
+  , _markerOrient      :: !(Maybe MarkerOrientation)
+    -- | Map the `markerUnits` attribute.
+  , _markerUnits       :: !(Maybe MarkerUnit)
+    -- | Optional viewbox
+  , _markerViewBox     :: !(Maybe (Double, Double, Double, Double))
+    -- | Elements defining the marker.
+  , _markerOverflow    :: !(Maybe Overflow)
+    -- | preserveAspectRatio attribute
+  , _markerAspectRatio :: !PreserveAspectRatio
+    -- | Elements defining the marker.
+  , _markerElements :: [Tree]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Marker type.
+makeClassy ''Marker
+
+instance WithDrawAttributes Marker where
+    drawAttr = markerDrawAttributes
+
+instance WithDefaultSvg Marker where
+  defaultSvg = Marker
+    { _markerDrawAttributes = mempty
+    , _markerRefPoint = (Num 0, Num 0)
+    , _markerWidth = Just (Num 3)
+    , _markerHeight = Just (Num 3)
+    , _markerOrient = Nothing -- MarkerOrientation
+    , _markerUnits = Nothing -- MarkerUnitStrokeWidth
+    , _markerViewBox = Nothing
+    , _markerOverflow = Nothing
+    , _markerElements = mempty
+    , _markerAspectRatio = defaultSvg
+    }
+
+-- | Insert element in the first sublist in the list of list.
+appNode :: [[a]] -> a -> [[a]]
+appNode [] e = [[e]]
+appNode (curr:above) e = (e:curr) : above
+
+-- | Map a tree while propagating context information.
+-- The function passed in parameter receive a list
+-- representing the the path used to go arrive to the
+-- current node.
+zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree
+zipTree f = dig [] where
+  dig prev e@None = f $ appNode prev e
+  dig prev e@(UseTree _ Nothing) = f $ appNode prev e
+  dig prev e@(UseTree nfo (Just u)) =
+      f . appNode prev . UseTree nfo . Just $ dig ([] : appNode prev e) u
+  dig prev e@(GroupTree g) =
+      f . appNode prev . GroupTree $ zipGroup (appNode prev e) g
+  dig prev e@(SymbolTree g) =
+      f . appNode prev . SymbolTree . Symbol .
+            zipGroup (appNode prev e) $ _groupOfSymbol g
+  dig prev e@(PathTree _) = f $ appNode prev e
+  dig prev e@(CircleTree _) = f $ appNode prev e
+  dig prev e@(PolyLineTree _) = f $ appNode prev e
+  dig prev e@(PolygonTree _) = f $ appNode prev e
+  dig prev e@(EllipseTree _) = f $ appNode prev e
+  dig prev e@(LineTree _) = f $ appNode prev e
+  dig prev e@(RectangleTree _) = f $ appNode prev e
+  dig prev e@(TextTree _ _) = f $ appNode prev e
+  dig prev e@(ImageTree _) = f $ appNode prev e
+  dig prev e@(MeshGradientTree _) = f $ appNode prev e
+
+  zipGroup prev g = g { _groupChildren = updatedChildren }
+    where
+      groupChild = _groupChildren g
+      updatedChildren =
+        [dig (c:prev) child
+            | (child, c) <- zip groupChild $ inits groupChild]
+
+-- | Fold all nodes of a SVG tree.
+foldTree :: (a -> Tree -> a) -> a -> Tree -> a
+foldTree f = go where
+  go acc e = case e of
+    None            -> f acc e
+    UseTree _ _     -> f acc e
+    PathTree _      -> f acc e
+    CircleTree _    -> f acc e
+    PolyLineTree _  -> f acc e
+    PolygonTree _   -> f acc e
+    EllipseTree _   -> f acc e
+    LineTree _      -> f acc e
+    RectangleTree _ -> f acc e
+    TextTree    _ _ -> f acc e
+    ImageTree _     -> f acc e
+    MeshGradientTree _ -> f acc e
+    GroupTree g     ->
+      let subAcc = F.foldl' go acc $ _groupChildren g in
+      f subAcc e
+    SymbolTree s    ->
+      let subAcc =
+            F.foldl' go acc . _groupChildren $ _groupOfSymbol s in
+      f subAcc e
+
+-- | Helper function mapping every tree element.
+mapTree :: (Tree -> Tree) -> Tree -> Tree
+mapTree f = go where
+  go e@None = f e
+  go e@(UseTree _ _) = f e
+  go (GroupTree g) = f . GroupTree $ mapGroup g
+  go (SymbolTree g) =
+      f . SymbolTree . Symbol . mapGroup $ _groupOfSymbol g
+  go e@(PathTree _) = f e
+  go e@(CircleTree _) = f e
+  go e@(PolyLineTree _) = f e
+  go e@(PolygonTree _) = f e
+  go e@(EllipseTree _) = f e
+  go e@(LineTree _) = f e
+  go e@(RectangleTree _) = f e
+  go e@(TextTree _ _) = f e
+  go e@(ImageTree _) = f e
+  go e@(MeshGradientTree _) = f e
+
+  mapGroup g =
+      g { _groupChildren = map go $ _groupChildren g }
+
+-- | For every element of a svg tree, associate
+-- it's SVG tag name.
+nameOfTree :: Tree -> T.Text
+nameOfTree v =
+  case v of
+   None     -> ""
+   UseTree _ _     -> "use"
+   GroupTree _     -> "g"
+   SymbolTree _    -> "symbol"
+   PathTree _      -> "path"
+   CircleTree _    -> "circle"
+   PolyLineTree _  -> "polyline"
+   PolygonTree _   -> "polygon"
+   EllipseTree _   -> "ellipse"
+   LineTree _      -> "line"
+   RectangleTree _ -> "rectangle"
+   TextTree    _ _ -> "text"
+   ImageTree _     -> "image"
+   MeshGradientTree _ -> "meshgradient"
+
+drawAttrOfTree :: Tree -> DrawAttributes
+drawAttrOfTree v = case v of
+  None -> mempty
+  UseTree e _ -> e ^. drawAttr
+  GroupTree e -> e ^. drawAttr
+  SymbolTree e -> e ^. drawAttr
+  PathTree e -> e ^. drawAttr
+  CircleTree e -> e ^. drawAttr
+  PolyLineTree e -> e ^. drawAttr
+  PolygonTree e -> e ^. drawAttr
+  EllipseTree e -> e ^. drawAttr
+  LineTree e -> e ^. drawAttr
+  RectangleTree e -> e ^. drawAttr
+  TextTree _ e -> e ^. drawAttr
+  ImageTree e -> e ^. drawAttr
+  MeshGradientTree e -> e ^. drawAttr
+
+setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree
+setDrawAttrOfTree v attr = case v of
+  None -> None
+  UseTree e m -> UseTree (e & drawAttr .~ attr) m
+  GroupTree e -> GroupTree $ e & drawAttr .~ attr
+  SymbolTree e -> SymbolTree $ e & drawAttr .~ attr
+  PathTree e -> PathTree $ e & drawAttr .~ attr
+  CircleTree e -> CircleTree $ e & drawAttr .~ attr
+  PolyLineTree e -> PolyLineTree $ e & drawAttr .~ attr
+  PolygonTree e -> PolygonTree $ e & drawAttr .~ attr
+  EllipseTree e -> EllipseTree $ e & drawAttr .~ attr
+  LineTree e -> LineTree $ e & drawAttr .~ attr
+  RectangleTree e -> RectangleTree $ e & drawAttr .~ attr
+  TextTree a e -> TextTree a $ e & drawAttr .~ attr
+  ImageTree e -> ImageTree $ e & drawAttr .~ attr
+  MeshGradientTree e -> MeshGradientTree $ e & drawAttr .~ attr
+
+instance WithDrawAttributes Tree where
+    drawAttr = lens drawAttrOfTree setDrawAttrOfTree
+
+instance WithDefaultSvg Tree where
+    defaultSvg = None
+
+-- | Define the possible values for the `spreadMethod`
+-- values used for the gradient definitions.
+data Spread
+    = SpreadRepeat  -- ^ `reapeat` value
+    | SpreadPad     -- ^ `pad` value
+    | SpreadReflect -- ^ `reflect value`
+    deriving (Eq, Show)
+
+-- | Define a `<linearGradient>` tag.
+data LinearGradient = LinearGradient
+    { -- | Define coordinate system of the gradient,
+      -- associated to the `gradientUnits` attribute.
+      _linearGradientUnits  :: CoordinateUnits
+      -- | Point defining the beginning of the line gradient.
+      -- Associated to the `x1` and `y1` attribute.
+    , _linearGradientStart  :: Point
+      -- | Point defining the end of the line gradient.
+      -- Associated to the `x2` and `y2` attribute.
+    , _linearGradientStop   :: Point
+      -- | Define how to handle the values outside
+      -- the gradient start and stop. Associated to the
+      -- `spreadMethod` attribute.
+    , _linearGradientSpread :: Spread
+      -- | Define the transformation to apply to the
+      -- gradient points. Associated to the `gradientTransform`
+      -- attribute.
+    , _linearGradientTransform :: [Transformation]
+      -- | List of color stops of the linear gradient.
+    , _linearGradientStops  :: [GradientStop]
+    }
+    deriving (Eq, Show)
+
+-- | Lenses for the LinearGradient type.
+makeClassy ''LinearGradient
+
+instance WithDefaultSvg LinearGradient where
+  defaultSvg = LinearGradient
+    { _linearGradientUnits     = CoordBoundingBox
+    , _linearGradientStart     = (Percent 0, Percent 0)
+    , _linearGradientStop      = (Percent 1, Percent 0)
+    , _linearGradientSpread    = SpreadPad
+    , _linearGradientTransform = []
+    , _linearGradientStops     = []
+    }
+
+-- | Define a `<radialGradient>` tag.
+data RadialGradient = RadialGradient
+  { -- | Define coordinate system of the gradient,
+    -- associated to the `gradientUnits` attribute.
+    _radialGradientUnits   :: CoordinateUnits
+    -- | Center of the radial gradient. Associated to
+    -- the `cx` and `cy` attributes.
+  , _radialGradientCenter  :: Point
+    -- | Radius of the radial gradient. Associated to
+    -- the `r` attribute.
+  , _radialGradientRadius  :: Number
+    -- | X coordinate of the focus point of the radial
+    -- gradient. Associated to the `fx` attribute.
+  , _radialGradientFocusX  :: Maybe Number
+    -- | Y coordinate of the focus point of the radial
+    -- gradient. Associated to the `fy` attribute.
+  , _radialGradientFocusY  :: Maybe Number
+    -- | Define how to handle the values outside
+    -- the gradient start and stop. Associated to the
+    -- `spreadMethod` attribute.
+  , _radialGradientSpread  :: Spread
+    -- | Define the transformation to apply to the
+    -- gradient points. Associated to the `gradientTransform`
+    -- attribute.
+  , _radialGradientTransform :: [Transformation]
+    -- | List of color stops of the radial gradient.
+  , _radialGradientStops   :: [GradientStop]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the RadialGradient type.
+makeClassy ''RadialGradient
+
+instance WithDefaultSvg RadialGradient where
+  defaultSvg = RadialGradient
+    { _radialGradientUnits   = CoordBoundingBox
+    , _radialGradientCenter  = (Percent 0.5, Percent 0.5)
+    , _radialGradientRadius  = Percent 0.5
+    , _radialGradientFocusX  = Nothing
+    , _radialGradientFocusY  = Nothing
+    , _radialGradientSpread  = SpreadPad
+    , _radialGradientTransform = []
+    , _radialGradientStops   = []
+    }
+
+-- | Define a SVG `<mask>` tag.
+data Mask = Mask
+  { -- | Drawing attributes of the Mask
+    _maskDrawAttributes :: DrawAttributes
+    -- | Correspond to the `maskContentUnits` attributes.
+  , _maskContentUnits :: CoordinateUnits
+    -- | Mapping to the `maskUnits` attribute.
+  , _maskUnits        :: CoordinateUnits
+    -- | Map to the `x` and `y` attributes.
+  , _maskPosition     :: Point
+    -- | Map to the `width` attribute
+  , _maskWidth        :: Number
+    -- | Map to the `height` attribute.
+  , _maskHeight       :: Number
+    -- | Children of the `<mask>` tag.
+  , _maskContent      :: [Tree]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the Mask type.
+makeClassy ''Mask
+
+instance WithDrawAttributes Mask where
+  drawAttr = maskDrawAttributes
+
+instance WithDefaultSvg Mask where
+  defaultSvg = Mask
+    { _maskDrawAttributes = mempty
+    , _maskContentUnits = CoordUserSpace
+    , _maskUnits        = CoordBoundingBox
+    , _maskPosition     = (Percent (-0.1), Percent (-0.1))
+    , _maskWidth        = Percent 1.2
+    , _maskHeight       = Percent 1.2
+    , _maskContent      = []
+    }
+
+-- | Define a `<clipPath>` tag.
+data ClipPath = ClipPath
+  { _clipPathDrawAttributes :: DrawAttributes
+    -- | Maps to the `clipPathUnits` attribute
+  , _clipPathUnits          :: CoordinateUnits
+    -- | Maps to the content of the tree
+  , _clipPathContent        :: [Tree]
+  }
+  deriving (Eq, Show)
+
+-- | Lenses for the ClipPath type.
+makeClassy ''ClipPath
+
+instance WithDrawAttributes ClipPath where
+  drawAttr = clipPathDrawAttributes
+
+instance WithDefaultSvg ClipPath where
+  defaultSvg = ClipPath
+    { _clipPathDrawAttributes = mempty
+    , _clipPathUnits = CoordUserSpace
+    , _clipPathContent = mempty
+    }
+
+-- | Define a `<pattern>` tag.
+data Pattern = Pattern
+    { -- | Pattern drawing attributes.
+      _patternDrawAttributes :: !DrawAttributes
+      -- | Possible `viewBox`.
+    , _patternViewBox  :: !(Maybe (Double, Double, Double, Double))
+      -- | Width of the pattern tile, mapped to the
+      -- `width` attribute
+    , _patternWidth    :: !Number
+      -- | Height of the pattern tile, mapped to the
+      -- `height` attribute
+    , _patternHeight   :: !Number
+      -- | Pattern tile base, mapped to the `x` and
+      -- `y` attributes.
+    , _patternPos      :: !Point
+      -- | Patterns can be chained, so this is a potential
+      -- reference to another pattern
+    , _patternHref     :: !String
+      -- | Elements used in the pattern.
+    , _patternElements :: ![Tree]
+      -- | Define the cordinate system to use for
+      -- the pattern. Mapped to the `patternUnits`
+      -- attribute.
+    , _patternUnit        :: !CoordinateUnits
+      -- | Value of the "preserveAspectRatio" attribute
+    , _patternAspectRatio :: !PreserveAspectRatio 
+      -- | Value of "patternTransform" attribute
+    , _patternTransform   :: !(Maybe [Transformation])
+    }
+    deriving Show
+
+-- | Lenses for the Patter type.
+makeClassy ''Pattern
+
+instance WithDrawAttributes Pattern where
+    drawAttr = patternDrawAttributes
+
+instance WithDefaultSvg Pattern where
+  defaultSvg = Pattern
+    { _patternViewBox  = Nothing
+    , _patternWidth    = Num 0
+    , _patternHeight   = Num 0
+    , _patternPos      = (Num 0, Num 0)
+    , _patternElements = []
+    , _patternUnit = CoordBoundingBox
+    , _patternDrawAttributes = mempty
+    , _patternAspectRatio = defaultSvg
+    , _patternHref = ""
+    , _patternTransform = mempty
+    }
+
+-- | Sum types helping keeping track of all the namable
+-- elemens in a SVG document.
+data Element
+    = ElementLinearGradient LinearGradient
+    | ElementRadialGradient RadialGradient
+    | ElementMeshGradient   MeshGradient
+    | ElementGeometry Tree
+    | ElementPattern  Pattern
+    | ElementMarker Marker
+    | ElementMask Mask
+    | ElementClipPath ClipPath
+    deriving Show
+
+-- | Represent a full svg document with style,
+-- geometry and named elements.
+data Document = Document
+    { _viewBox          :: Maybe (Double, Double, Double, Double)
+    , _width            :: Maybe Number
+    , _height           :: Maybe Number
+    , _elements         :: [Tree]
+    , _definitions      :: M.Map String Element
+    , _description      :: String
+    , _styleRules       :: [CssRule]
+    , _documentLocation :: FilePath
+    }
+    deriving Show
+
+-- | Lenses associated to a SVG document.
+makeClassy ''Document
+
+-- | Calculate the document size in function of the
+-- different available attributes in the document.
+documentSize :: Dpi -> Document -> (Int, Int)
+documentSize _ Document { _viewBox = Just (x1, y1, x2, y2)
+                        , _width = Just (Percent pw)
+                        , _height = Just (Percent ph)
+                        } =
+    (floor $ dx * pw, floor $ dy * ph)
+      where
+        dx = abs $ x2 - x1
+        dy = abs $ y2 - y1
+documentSize _ Document { _width = Just (Num w)
+                        , _height = Just (Num h) } = (floor w, floor h)
+documentSize dpi doc@(Document { _width = Just w
+                               , _height = Just h }) =
+  documentSize dpi $ doc
+    { _width = Just $ toUserUnit dpi w
+    , _height = Just $ toUserUnit dpi h }
+documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } =
+    (floor . abs $ x2 - x1, floor . abs $ y2 - y1)
+documentSize _ _ = (1, 1)
+
+mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a
+mayMerge (Just a) (Just b) = Just $ mappend a b
+mayMerge _ b@(Just _) = b
+mayMerge a Nothing = a
+
+instance Monoid DrawAttributes where
+    mempty = DrawAttributes
+        { _strokeWidth      = Last Nothing
+        , _strokeColor      = Last Nothing
+        , _strokeOpacity    = Nothing
+        , _strokeLineCap    = Last Nothing
+        , _strokeLineJoin   = Last Nothing
+        , _strokeMiterLimit = Last Nothing
+        , _fillColor        = Last Nothing
+        , _groupOpacity     = Nothing
+        , _fillOpacity      = Nothing
+        , _fontSize         = Last Nothing
+        , _fontFamily       = Last Nothing
+        , _fontStyle        = Last Nothing
+        , _transform        = Nothing
+        , _fillRule         = Last Nothing
+        , _attrClass        = mempty
+        , _attrId           = Nothing
+        , _strokeOffset     = Last Nothing
+        , _strokeDashArray  = Last Nothing
+        , _textAnchor       = Last Nothing
+        , _maskRef          = Last Nothing
+        , _clipPathRef      = Last Nothing
+        , _clipRule         = Last Nothing
+
+        , _markerStart      = Last Nothing
+        , _markerMid        = Last Nothing
+        , _markerEnd        = Last Nothing
+        }
+
+    mappend a b = DrawAttributes
+        { _strokeWidth = (mappend `on` _strokeWidth) a b
+        , _strokeColor =  (mappend `on` _strokeColor) a b
+        , _strokeLineCap = (mappend `on` _strokeLineCap) a b
+        , _strokeOpacity = (opacityMappend `on` _strokeOpacity) a b
+        , _strokeLineJoin = (mappend `on` _strokeLineJoin) a b
+        , _strokeMiterLimit = (mappend `on` _strokeMiterLimit) a b
+        , _fillColor =  (mappend `on` _fillColor) a b
+        , _fillOpacity = (opacityMappend `on` _fillOpacity) a b
+        , _fontSize = (mappend `on` _fontSize) a b
+        , _transform = (mayMerge `on` _transform) a b
+        , _fillRule = (mappend `on` _fillRule) a b
+        , _attrClass = _attrClass b
+        , _attrId = _attrId b
+        , _groupOpacity = _groupOpacity b
+        , _strokeOffset = (mappend `on` _strokeOffset) a b
+        , _strokeDashArray = (mappend `on` _strokeDashArray) a b
+        , _fontFamily = (mappend `on` _fontFamily) a b
+        , _fontStyle = (mappend `on` _fontStyle) a b
+        , _textAnchor = (mappend `on` _textAnchor) a b
+        , _maskRef = (mappend `on` _maskRef) a b
+        , _clipPathRef = (mappend `on` _clipPathRef) a b
+        , _clipRule = (mappend `on` _clipRule) a b
+        , _markerStart = (mappend `on` _markerStart) a b
+        , _markerMid = (mappend `on` _markerMid) a b
+        , _markerEnd = (mappend `on` _markerEnd) a b
+        }
+      where
+        opacityMappend Nothing Nothing = Nothing
+        opacityMappend (Just v) Nothing = Just v
+        opacityMappend Nothing (Just v) = Just v
+        opacityMappend (Just v) (Just v2) = Just $ v * v2
+
+instance WithDefaultSvg DrawAttributes where
+  defaultSvg = mempty
+
+instance CssMatcheable Tree where
+  cssAttribOf _ _ = Nothing
+  cssClassOf = view (drawAttr . attrClass)
+  cssIdOf = fmap T.pack . view (drawAttr . attrId)
+  cssNameOf = nameOfTree
+

@@ -1,1227 +1,1236 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-module Graphics.Svg.XmlParser( xmlOfDocument-                             , unparseDocument--                             , SvgAttributeLens( .. )-                             , drawAttributesList-                             ) where---#if !MIN_VERSION_base(4,6,0)-import Text.Read( reads )-#else-import Text.Read( readMaybe )-#endif--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( pure, (<$>), (<$), (<*>) )-import Data.Foldable( foldMap )-import Data.Monoid( mempty )-#endif--import Control.Applicative( (<|>), many )--import Control.Lens hiding( transform, children, elements, element )-import Control.Monad.State.Strict( State, runState, modify, gets )-import Data.Maybe( fromMaybe, catMaybes )-import Data.Monoid( Last( Last ), getLast, (<>) )-import Data.List( foldl', intercalate )-import Text.XML.Light.Proc( findAttrBy, elChildren, strContent )-import qualified Text.XML.Light as X-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Map as M-import Data.Attoparsec.Text( Parser, string, parseOnly, many1 )-import Codec.Picture( PixelRGBA8( .. ) )-import Graphics.Svg.Types-import Graphics.Svg.PathParser-import Graphics.Svg.ColorParser-import Graphics.Svg.CssTypes( CssDeclaration( .. )-                            , CssElement( .. )-                            , CssRule-                            , tserialize-                            )-import Graphics.Svg.CssParser( complexNumber-                             , num-                             , ruleSet-                             , dashArray-                             , styleString-                             , numberList )--import Text.Printf( printf )--{-import Debug.Trace-}--#if !MIN_VERSION_base(4,6,0)-readMaybe :: Read a => String -> Maybe a-readMaybe str = case reads str of-  [] -> Nothing-  (x, _):_ -> Just x-#endif--nodeName :: X.Element -> String-nodeName = X.qName . X.elName--attributeFinder :: String -> X.Element -> Maybe String-attributeFinder str =-    findAttrBy (\a -> X.qName a == str)---- | Helper class to help simplify parsing code--- for various attributes.-class ParseableAttribute a where-  aparse :: String -> Maybe a-  aserialize :: a -> Maybe String--instance ParseableAttribute v => ParseableAttribute (Maybe v) where-  aparse = fmap Just . aparse-  aserialize = (>>= aserialize)--instance ParseableAttribute v => ParseableAttribute (Last v) where-  aparse = fmap Last . aparse-  aserialize = aserialize . getLast--instance ParseableAttribute String where-  aparse = Just-  aserialize = Just--instance ParseableAttribute Number where-  aparse = parseMayStartDot complexNumber-  aserialize = Just . serializeNumber--instance ParseableAttribute [Number] where-  aparse = parse dashArray-  aserialize = Just . serializeDashArray--instance ParseableAttribute PixelRGBA8 where-  aparse = parse colorParser-  aserialize = Just . colorSerializer--instance ParseableAttribute [PathCommand] where-  aparse = parse pathParser-  aserialize = Just . serializeCommands--instance ParseableAttribute GradientPathCommand where-  aparse = parse gradientCommand-  aserialize = Just . serializeGradientCommand--instance ParseableAttribute [RPoint] where-  aparse = parse pointData-  aserialize = Just . serializePoints--instance ParseableAttribute Double where-  aparse = parseMayStartDot num-  aserialize v = Just $ printf "%g" v--instance ParseableAttribute Texture where-  aparse = parse textureParser-  aserialize = Just . textureSerializer--instance ParseableAttribute [Transformation] where-  aparse = parse $ many transformParser-  aserialize = Just . serializeTransformations--instance ParseableAttribute Alignment where-  aparse s = Just $ case s of-    "none" -> AlignNone -    "xMinYMin" -> AlignxMinYMin-    "xMidYMin" -> AlignxMidYMin-    "xMaxYMin" -> AlignxMaxYMin-    "xMinYMid" -> AlignxMinYMid-    "xMidYMid" -> AlignxMidYMid-    "xMaxYMid" -> AlignxMaxYMid-    "xMinYMax" -> AlignxMinYMax-    "xMidYMax" -> AlignxMidYMax-    "xMaxYMax" -> AlignxMaxYMax-    _ -> _aspectRatioAlign defaultSvg--  aserialize v = Just $ case v of-    AlignNone -> "none" -    AlignxMinYMin -> "xMinYMin"-    AlignxMidYMin -> "xMidYMin"-    AlignxMaxYMin -> "xMaxYMin"-    AlignxMinYMid -> "xMinYMid"-    AlignxMidYMid -> "xMidYMid"-    AlignxMaxYMid -> "xMaxYMid"-    AlignxMinYMax -> "xMinYMax"-    AlignxMidYMax -> "xMidYMax"-    AlignxMaxYMax -> "xMaxYMax"--instance ParseableAttribute MeshGradientType where-  aparse s = Just $ case s of-    "bilinear" -> GradientBilinear-    "bicubic" -> GradientBicubic-    _ -> GradientBilinear-  -  aserialize v = Just $ case v of-    GradientBilinear -> "bilinear"-    GradientBicubic -> "bicubic"--instance ParseableAttribute MeetSlice where-  aparse s = case s of-    "meet" -> Just Meet-    "slice" -> Just Slice-    _ -> Nothing--  aserialize v = Just $ case v of-    Meet -> "meet"-    Slice -> "slice"--instance ParseableAttribute PreserveAspectRatio where-  aserialize v = Just $ defer <> align <> meetSlice where-    defer = if _aspectRatioDefer v then "defer " else ""-    align = fromMaybe "" . aserialize $ _aspectRatioAlign v-    meetSlice = fromMaybe "" $ aserialize =<< _aspectRatioMeetSlice v--  aparse s = case words s of-      [] -> Nothing-      [align] -> Just $ defaultSvg { _aspectRatioAlign = alignOf align }-      ["defer", align] ->-          Just $ defaultSvg-            { _aspectRatioDefer = True-            , _aspectRatioAlign = alignOf align-            }-      [align, meet] ->-          Just $ defaultSvg-            { _aspectRatioMeetSlice = aparse meet-            , _aspectRatioAlign = alignOf align-            }-      ["defer", align, meet] ->-          Just $ PreserveAspectRatio -              { _aspectRatioDefer = True-              , _aspectRatioAlign = alignOf align-              , _aspectRatioMeetSlice = aparse meet-              }-      _ -> Nothing-    where-      alignOf = fromMaybe (_aspectRatioAlign defaultSvg) . aparse--instance ParseableAttribute Cap where-  aparse s = case s of-    "butt" -> Just CapButt-    "round" -> Just CapRound-    "square" -> Just CapSquare-    _ -> Nothing--  aserialize c = Just $ case c of-    CapButt -> "butt"-    CapRound -> "round"-    CapSquare -> "square"--instance ParseableAttribute TextAnchor where-  aparse s = case s of-    "middle" -> Just TextAnchorMiddle-    "start" -> Just TextAnchorStart-    "end" -> Just TextAnchorEnd-    _ -> Nothing--  aserialize t = Just $ case t of-    TextAnchorMiddle -> "middle"-    TextAnchorStart -> "start"-    TextAnchorEnd -> "end"--instance ParseableAttribute ElementRef where-  aparse s = case parseOnly pa $ T.pack s of-     Left _ -> Nothing-     Right v -> Just v-    where-      pa = (RefNone <$ string "none")-        <|> (Ref <$> urlRef)--  aserialize c = Just $ case c of-    Ref r -> "url(#" <> r <> ")"-    RefNone -> "none"--instance ParseableAttribute LineJoin where-  aparse s = case s of-    "miter" -> Just JoinMiter-    "round" -> Just JoinRound-    "bevel" -> Just JoinBevel-    _ -> Nothing--  aserialize j = Just $ case j of-    JoinMiter -> "miter"-    JoinRound -> "round"-    JoinBevel -> "bevel"--instance ParseableAttribute CoordinateUnits where-  aparse s = case s of-    "userSpaceOnUse" -> Just CoordUserSpace-    "objectBoundingBox" -> Just CoordBoundingBox-    _ -> Just CoordBoundingBox--  aserialize uni = Just $ case uni of-    CoordUserSpace -> "userSpaceOnUse"-    CoordBoundingBox -> "objectBoundingBox"--instance ParseableAttribute Spread where-  aparse s = case s of-    "pad" -> Just SpreadPad-    "reflect" -> Just SpreadReflect-    "repeat" -> Just SpreadRepeat-    _ -> Nothing--  aserialize s = Just $ case s of-    SpreadPad -> "pad"-    SpreadReflect -> "reflect"-    SpreadRepeat -> "repeat"--instance ParseableAttribute FillRule where-  aparse s = case s of-    "nonzero" -> Just FillNonZero-    "evenodd" -> Just FillEvenOdd-    _ -> Nothing--  aserialize f = Just $ case f of-    FillNonZero -> "nonzero"-    FillEvenOdd -> "evenodd"--instance ParseableAttribute TextAdjust where-  aparse s = Just $ case s of-    "spacing" -> TextAdjustSpacing-    "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs-    _ -> TextAdjustSpacing--  aserialize a = Just $ case a of-    TextAdjustSpacing -> "spacing"-    TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs"--instance ParseableAttribute MarkerUnit where-  aparse s = case s of-    "strokeWidth" -> Just MarkerUnitStrokeWidth-    "userSpaceOnUse" -> Just MarkerUnitUserSpaceOnUse-    _ -> Nothing--  aserialize u = Just $ case u of-    MarkerUnitStrokeWidth -> "strokeWidth"-    MarkerUnitUserSpaceOnUse -> "userSpaceOnUse"--instance ParseableAttribute Overflow where-  aparse s = case s of-    "visible" -> Just OverflowVisible-    "hidden" -> Just OverflowHidden-    _ -> Nothing--  aserialize u = Just $ case u of-    OverflowVisible -> "visible"-    OverflowHidden -> "hidden"--instance ParseableAttribute MarkerOrientation where-  aparse s = case (s, readMaybe s) of-    ("auto", _) -> Just OrientationAuto-    (_, Just f) -> Just $ OrientationAngle f-    _ -> Nothing--  aserialize s = Just $ case s of-    OrientationAuto -> "auto"-    OrientationAngle f -> show f--instance ParseableAttribute (Double, Double, Double, Double) where-  aparse = parse viewBoxParser-  aserialize = Just . serializeViewBox--instance ParseableAttribute TextPathMethod where-  aparse s = case s of-    "align" -> Just TextPathAlign-    "stretch" -> Just TextPathStretch-    _ -> Nothing-  aserialize m = Just $ case m of-    TextPathAlign -> "align"-    TextPathStretch -> "stretch"--instance ParseableAttribute TextPathSpacing where-  aparse s = case s of-    "auto" -> Just TextPathSpacingAuto-    "exact" -> Just TextPathSpacingExact-    _ -> Nothing--  aserialize s = Just $ case s of-    TextPathSpacingAuto -> "auto"-    TextPathSpacingExact -> "exact"--parse :: Parser a -> String -> Maybe a-parse p str = case parseOnly p (T.pack str) of-  Left _ -> Nothing-  Right r -> Just r--parseMayStartDot :: Parser a -> String -> Maybe a-parseMayStartDot p l@('.':_) = parse p ('0':l)-parseMayStartDot p l = parse p l--xmlUpdate :: (XMLUpdatable a) => a -> X.Element -> a-xmlUpdate initial el = foldl' grab initial attributes-  where-    grab value updater =-        case attributeFinder (_attributeName updater) el of-          Nothing -> value-          Just v -> _attributeUpdater updater value v--xmlUnparse :: (XMLUpdatable a) => X.Element -> a-xmlUnparse = xmlUpdate defaultSvg--xmlUnparseWithDrawAttr-    :: (XMLUpdatable a, WithDrawAttributes a)-    => X.Element -> a-xmlUnparseWithDrawAttr e =-    xmlUnparse e & drawAttr .~ xmlUnparse e--data SvgAttributeLens t = SvgAttributeLens-  { _attributeName       :: String-  , _attributeUpdater    :: t -> String -> t-  , _attributeSerializer :: t -> Maybe String-  }--class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where-  xmlTagName :: treeNode -> String-  attributes :: [SvgAttributeLens treeNode]--  serializeTreeNode :: treeNode -> Maybe X.Element--setChildren :: X.Element -> [X.Content] -> X.Element-setChildren xNode children = xNode { X.elContent = children }--updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> Maybe X.Element -> Maybe X.Element-updateWithAccessor        _    _ Nothing = Nothing-updateWithAccessor accessor node (Just xNode) =-    Just . setChildren xNode . fmap  X.Elem . catMaybes $ serializeTreeNode <$> accessor node--genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> Maybe X.Element-genericSerializeNode node =-    Just . X.unode (xmlTagName node) $ concatMap generateAttribute attributes-  where-    generateAttribute attr = case _attributeSerializer attr node of-      Nothing -> []-      Just str -> return X.Attr-        { X.attrKey = xName $ _attributeName attr-        , X.attrVal = str-        }-        where-         xName "href" =-            X.QName { X.qName = "href"-                    , X.qURI = Nothing-                    , X.qPrefix = Just "xlink" }-         xName h = X.unqual h---mergeAttributes :: X.Element -> X.Element -> X.Element-mergeAttributes thisXml otherXml =-    thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml }--genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode)-                             => treeNode -> Maybe X.Element-genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where-  thisXml = genericSerializeNode node-  drawAttrNode = genericSerializeNode $ node ^. drawAttr--type CssUpdater =-    DrawAttributes -> [[CssElement]] -> DrawAttributes--opacitySetter :: String -> Lens' a (Maybe Float) -> SvgAttributeLens a-opacitySetter attribute elLens =-    SvgAttributeLens attribute updater serializer-  where-    serializer a = printf "%g" <$> a ^. elLens-    updater el str = case parseMayStartDot num str of-        Nothing -> el-        Just v -> el & elLens .~ Just (realToFrac v)--type Serializer e = e -> Maybe String--parserSetter :: String -> Lens' a e -> (String -> Maybe e) -> Serializer e-             -> SvgAttributeLens a-parserSetter attribute elLens parser serialize =-    SvgAttributeLens attribute updater serializer-  where-    updater el str = case parser str of-        Nothing -> el-        Just v -> el & elLens .~ v--    serializer  a = serialize $ a ^. elLens--parseIn :: (Eq a, WithDefaultSvg s, ParseableAttribute a)-        => String -> Lens' s a -> SvgAttributeLens s-parseIn attribute elLens =-    SvgAttributeLens attribute updater serializer-  where-    updater el str = case aparse str of-        Nothing -> el-        Just v -> el & elLens .~ v--    serializer a-      | v /= defaultVal = aserialize v-      | otherwise = Nothing-      where-        v = a ^. elLens-        defaultVal = defaultSvg ^. elLens--parserLastSetter :: String -> Lens' a (Last e) -> (String -> Maybe e) -> Serializer e-                 -> SvgAttributeLens a-parserLastSetter attribute elLens parser serialize =-    SvgAttributeLens attribute updater serializer-  where-    updater el str = case parser str of-        Nothing -> el-        Just v -> el & elLens .~ Last (Just v)--    serializer a = getLast (a ^. elLens) >>= serialize--classSetter :: SvgAttributeLens DrawAttributes-classSetter = SvgAttributeLens "class" updater serializer-  where-    updater el str =-      el & attrClass .~ (T.split (== ' ') $ T.pack str)--    serializer a = case a ^. attrClass of-      [] -> Nothing-      lst -> Just . T.unpack $ T.intercalate " " lst--cssUniqueNumber :: ASetter DrawAttributes DrawAttributes-                   a (Last Number)-                -> CssUpdater-cssUniqueNumber setter attr ((CssNumber n:_):_) =-    attr & setter .~ Last (Just n)-cssUniqueNumber _ attr _ = attr--cssUniqueFloat :: (Fractional n)-               => ASetter DrawAttributes DrawAttributes a (Maybe n)-               -> CssUpdater-cssUniqueFloat setter attr ((CssNumber (Num n):_):_) =-    attr & setter .~ Just (realToFrac n)-cssUniqueFloat _ attr _ = attr--cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Double)-               -> CssUpdater-cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) =-    attr & setter .~ Last (Just n)-cssUniqueMayFloat _ attr _ = attr--cssIdentAttr :: ParseableAttribute a => Lens' DrawAttributes a -> CssUpdater-cssIdentAttr setter attr ((CssIdent i:_):_) = case aparse $ T.unpack i of-    Nothing -> attr-    Just v -> attr & setter .~ v-cssIdentAttr _ attr _ = attr--fontFamilyParser :: CssUpdater-fontFamilyParser attr (lst:_) = attr & fontFamily .~ fontNames-  where-    fontNames = Last . Just $ T.unpack <$> extractString lst--    extractString [] = []-    extractString (CssIdent n:rest) = n : extractString rest-    extractString (CssString n:rest) = n : extractString rest-    extractString (_:rest) = extractString rest-fontFamilyParser attr _ = attr---cssUniqueTexture :: ASetter DrawAttributes DrawAttributes-                    a (Last Texture)-                 -> CssUpdater-cssUniqueTexture setter attr ((CssIdent "none":_):_) =-    attr & setter .~ Last (Just FillNone)-cssUniqueTexture setter attr ((CssColor c:_):_) =-    attr & setter .~ Last (Just $ ColorRef c)-cssUniqueTexture setter attr ((CssFunction "url" [CssReference c]:_):_) =-    attr & setter .~ Last (Just . TextureRef $ T.unpack c)-cssUniqueTexture _ attr _ = attr--cssElementRefSetter :: Lens' DrawAttributes (Last ElementRef)-                         -> CssUpdater-cssElementRefSetter setter attr ((CssFunction "url" [CssReference c]:_):_) =-    attr & setter .~ Last (Just . Ref $ T.unpack c)-cssElementRefSetter setter attr ((CssIdent "none":_):_) =-    attr & setter .~ Last (Just RefNone)-cssElementRefSetter _ attr _ = attr--cssMayStringSetter :: ASetter DrawAttributes DrawAttributes a (Maybe String)-                   -> CssUpdater-cssMayStringSetter setter attr ((CssIdent i:_):_) =-    attr & setter .~ Just (T.unpack i)-cssMayStringSetter setter attr ((CssString i:_):_) =-    attr & setter .~ Just (T.unpack i)-cssMayStringSetter _ attr _ = attr--cssNullSetter :: CssUpdater-cssNullSetter attr _ = attr--cssDashArray :: ASetter DrawAttributes DrawAttributes a (Last [Number])-             -> CssUpdater-cssDashArray setter attr (lst:_) =-  case [n | CssNumber n <- lst ] of-    [] -> attr-    v -> attr & setter .~ Last (Just v)-cssDashArray _ attr _ = attr---drawAttributesList :: [(SvgAttributeLens DrawAttributes, CssUpdater)]-drawAttributesList =-  [("stroke-width" `parseIn` strokeWidth, cssUniqueNumber strokeWidth)-  ,("stroke" `parseIn` strokeColor, cssUniqueTexture strokeColor)-  ,("fill" `parseIn` fillColor, cssUniqueTexture fillColor)-  ,("stroke-linecap" `parseIn` strokeLineCap, cssIdentAttr strokeLineCap)-  ,("stroke-linejoin" `parseIn` strokeLineJoin, cssIdentAttr strokeLineJoin)-  ,("stroke-miterlimit" `parseIn` strokeMiterLimit,-       cssUniqueMayFloat strokeMiterLimit)--  ,("transform" `parseIn` transform, const)-  ,(opacitySetter "opacity" groupOpacity, cssUniqueFloat groupOpacity)-  ,(opacitySetter "fill-opacity" fillOpacity, cssUniqueFloat fillOpacity)-  ,(opacitySetter "stroke-opacity" strokeOpacity, cssUniqueFloat strokeOpacity)-  ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize)-  ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate)-      (Just . intercalate ", "), fontFamilyParser)--  ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule)-  ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule)-  ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef)-  ,(classSetter, cssNullSetter) -- can't set class in CSS-  ,("id" `parseIn` attrId, cssMayStringSetter attrId)-  ,("stroke-dashoffset" `parseIn` strokeOffset,-      cssUniqueNumber strokeOffset)-  ,("stroke-dasharray" `parseIn` strokeDashArray, cssDashArray strokeDashArray)-  ,("text-anchor" `parseIn` textAnchor, cssIdentAttr textAnchor)-  ,("clip-path" `parseIn` clipPathRef, cssElementRefSetter clipPathRef)-  ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd)-  ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart)-  ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid)-  ]-  where-    commaSeparate =-        fmap (T.unpack . T.strip) . T.split (',' ==) . T.pack--serializeDashArray :: [Number] -> String-serializeDashArray =-   intercalate ", " . fmap serializeNumber--instance XMLUpdatable DrawAttributes where-  xmlTagName _ = "DRAWATTRIBUTES"-  attributes = styleAttribute : fmap fst drawAttributesList-  serializeTreeNode = genericSerializeNode--styleAttribute :: SvgAttributeLens DrawAttributes-styleAttribute = SvgAttributeLens-  { _attributeName       = "style"-  , _attributeUpdater    = updater-  , _attributeSerializer = const Nothing-  }-  where-    updater attrs style = case parse styleString style of-        Nothing -> attrs-        Just decls -> foldl' applyer attrs decls--    cssUpdaters = [(T.pack $ _attributeName n, u) | (n, u) <- drawAttributesList]-    applyer value (CssDeclaration txt elems) =-        case lookup txt cssUpdaters of-          Nothing -> value-          Just f -> f value elems--instance XMLUpdatable Rectangle where-  xmlTagName _ = "rect"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes =-    ["width" `parseIn` rectWidth-    ,"height" `parseIn` rectHeight-    ,"x" `parseIn` (rectUpperLeftCorner._1)-    ,"y" `parseIn` (rectUpperLeftCorner._2)-    ,"rx" `parseIn` (rectCornerRadius._1)-    ,"ry" `parseIn` (rectCornerRadius._2)-    ]--instance XMLUpdatable Image where-  xmlTagName _ = "image"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes =-    ["width" `parseIn` imageWidth-    ,"height" `parseIn` imageHeight-    ,"x" `parseIn` (imageCornerUpperLeft._1)-    ,"y" `parseIn` (imageCornerUpperLeft._2)-    ,parserSetter "href" imageHref (Just . dropSharp) Just-    ,"preserveAspectRatio" `parseIn` imageAspectRatio-    ]--instance XMLUpdatable Line where-  xmlTagName _ = "line"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes =-    ["x1" `parseIn` (linePoint1._1)-    ,"y1" `parseIn` (linePoint1._2)-    ,"x2" `parseIn` (linePoint2._1)-    ,"y2" `parseIn` (linePoint2._2)-    ]--instance XMLUpdatable Ellipse where-  xmlTagName _ = "ellipse"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes =-    ["cx" `parseIn` (ellipseCenter._1)-    ,"cy" `parseIn` (ellipseCenter._2)-    ,"rx" `parseIn` ellipseXRadius-    ,"ry" `parseIn` ellipseYRadius-    ]--instance XMLUpdatable Circle where-  xmlTagName _ = "circle"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes =-    ["cx" `parseIn` (circleCenter._1)-    ,"cy" `parseIn` (circleCenter._2)-    ,"r" `parseIn` circleRadius-    ]--instance XMLUpdatable Mask where-  xmlTagName _ = "mask"-  serializeTreeNode node =-      updateWithAccessor _maskContent node $-          genericSerializeWithDrawAttr node--  attributes =-    ["x" `parseIn` (maskPosition._1)-    ,"y" `parseIn` (maskPosition._2)-    ,"width" `parseIn` maskWidth-    ,"height" `parseIn` maskHeight-    ,"maskContentUnits" `parseIn` maskContentUnits-    ,"maskUnits" `parseIn` maskUnits-    ]--instance XMLUpdatable ClipPath where-  xmlTagName _ = "clipPath"-  serializeTreeNode node =-      updateWithAccessor _clipPathContent node $-          genericSerializeWithDrawAttr node-  attributes =-    ["clipPathUnits" `parseIn` clipPathUnits]--instance XMLUpdatable Polygon where-  xmlTagName _ = "polygon"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes = ["points" `parseIn` polygonPoints]--instance XMLUpdatable PolyLine where-  xmlTagName _ =  "polyline"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes = ["points" `parseIn` polyLinePoints]--instance XMLUpdatable Path where-  xmlTagName _ =  "path"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes = ["d" `parseIn` pathDefinition]--instance XMLUpdatable MeshGradientPatch where-  xmlTagName _ = "meshpatch"-  attributes = []-  serializeTreeNode node =-     updateWithAccessor _meshGradientPatchStops node $ genericSerializeNode node--instance XMLUpdatable MeshGradientRow where-  xmlTagName _ = "meshrow"-  serializeTreeNode node =-     updateWithAccessor _meshGradientRowPatches node $ genericSerializeNode node-  attributes = []--instance XMLUpdatable MeshGradient where-  xmlTagName _ = "meshgradient"-  serializeTreeNode node =-     updateWithAccessor _meshGradientRows node $ genericSerializeWithDrawAttr node-  attributes =-    ["x" `parseIn` meshGradientX-    ,"y" `parseIn` meshGradientY-    ,"type" `parseIn` meshGradientType-    ,"gradientUnits" `parseIn` meshGradientUnits-    ,"gradientTransform" `parseIn` meshGradientTransform-    ]---instance XMLUpdatable LinearGradient where-  xmlTagName _ = "linearGradient"-  serializeTreeNode node =-     updateWithAccessor _linearGradientStops node $ genericSerializeNode node--  attributes =-    ["gradientTransform" `parseIn` linearGradientTransform-    ,"gradientUnits" `parseIn` linearGradientUnits-    ,"spreadMethod" `parseIn` linearGradientSpread-    ,"x1" `parseIn` (linearGradientStart._1)-    ,"y1" `parseIn` (linearGradientStart._2)-    ,"x2" `parseIn` (linearGradientStop._1)-    ,"y2" `parseIn` (linearGradientStop._2)-    ]--instance XMLUpdatable Tree where-  xmlTagName _ = "TREE"-  attributes = []-  serializeTreeNode e = case e of-    None -> Nothing-    UseTree u _ -> serializeTreeNode u-    GroupTree g -> serializeTreeNode g-    SymbolTree s -> serializeTreeNode s-    PathTree p -> serializeTreeNode p-    CircleTree c -> serializeTreeNode c-    PolyLineTree p -> serializeTreeNode p-    PolygonTree p -> serializeTreeNode p-    EllipseTree el -> serializeTreeNode el-    LineTree l -> serializeTreeNode l-    RectangleTree r -> serializeTreeNode r-    TextTree Nothing t -> serializeTreeNode t-    ImageTree i -> serializeTreeNode i-    MeshGradientTree m -> serializeTreeNode m-    TextTree (Just p) t -> do-       textNode <- serializeTreeNode t-       pathNode <- serializeTreeNode p-       let sub = [X.Elem . setChildren pathNode $ X.elContent textNode]-       return $ setChildren textNode sub---isNotNone :: Tree -> Bool-isNotNone None = False-isNotNone _ = True--instance XMLUpdatable (Group Tree) where-  xmlTagName _ = "g"-  serializeTreeNode node =-     updateWithAccessor (filter isNotNone . _groupChildren) node $-        genericSerializeWithDrawAttr node-  attributes = []--instance XMLUpdatable (Symbol Tree) where-  xmlTagName _ = "symbol"-  serializeTreeNode node =-     updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $-        genericSerializeWithDrawAttr node-  attributes =-     ["viewBox" `parseIn` (groupOfSymbol . groupViewBox)-     ,"preserveAspectRatio" `parseIn` (groupOfSymbol . groupAspectRatio)-     ]---instance XMLUpdatable RadialGradient where-  xmlTagName _ = "radialGradient"-  serializeTreeNode node =-     updateWithAccessor _radialGradientStops node $ genericSerializeNode node-  attributes =-    ["gradientTransform" `parseIn` radialGradientTransform-    ,"gradientUnits" `parseIn` radialGradientUnits-    ,"spreadMethod" `parseIn` radialGradientSpread-    ,"cx" `parseIn` (radialGradientCenter._1)-    ,"cy" `parseIn` (radialGradientCenter._2)-    ,"r"  `parseIn` radialGradientRadius-    ,"fx" `parseIn` radialGradientFocusX-    ,"fy" `parseIn` radialGradientFocusY-    ]--instance XMLUpdatable Use where-  xmlTagName _ = "use"-  serializeTreeNode = genericSerializeWithDrawAttr-  attributes =-    ["x" `parseIn` (useBase._1)-    ,"y" `parseIn` (useBase._2)-    ,"width" `parseIn` useWidth-    ,"height" `parseIn` useHeight-    ,parserSetter "href" useName (Just . dropSharp) (Just . ('#':))-    ]--dropSharp :: String -> String-dropSharp ('#':rest) = rest-dropSharp a = a--instance XMLUpdatable TextInfo where-  xmlTagName _ = "tspan"-  serializeTreeNode = genericSerializeNode-  attributes =-    [parserSetter "x" textInfoX (parse dashArray) dashNotEmpty-    ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty-    ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty-    ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty-    ,parserSetter "rotate" textInfoRotate-        (parse numberList)-        rotateNotEmpty-    ,"textLength" `parseIn` textInfoLength-    ]-    where-      dashNotEmpty [] = Nothing-      dashNotEmpty lst = Just $ serializeDashArray lst--      rotateNotEmpty [] = Nothing-      rotateNotEmpty lst =-          Just . unwords $ printf "%g" <$> lst---instance XMLUpdatable TextPath where-  xmlTagName _ =  "textPath"-  serializeTreeNode = genericSerializeNode-  attributes =-    ["startOffset" `parseIn` textPathStartOffset-    ,"method" `parseIn` textPathMethod-    ,"spacing" `parseIn` textPathSpacing-    ,parserSetter "href" textPathName (Just . dropSharp) (Just . ('#':))-    ]--instance XMLUpdatable Text where-  xmlTagName _ = "text"-  serializeTreeNode = serializeText-  attributes = ["lengthAdjust" `parseIn` textAdjust]---instance XMLUpdatable Pattern where-  xmlTagName _ = "pattern"-  serializeTreeNode node =-     updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node-  attributes =-    ["viewBox" `parseIn` patternViewBox-    ,"patternUnits" `parseIn` patternUnit-    ,"width" `parseIn` patternWidth-    ,"height" `parseIn` patternHeight-    ,"x" `parseIn` (patternPos._1)-    ,"y" `parseIn` (patternPos._2)-    ,"preserveAspectRatio" `parseIn` patternAspectRatio-    ]--instance XMLUpdatable Marker where-  xmlTagName _ = "marker"-  serializeTreeNode node =-     updateWithAccessor _markerElements node $ genericSerializeWithDrawAttr node-  attributes =-    ["refX" `parseIn` (markerRefPoint._1)-    ,"refY" `parseIn` (markerRefPoint._2)-    ,"markerWidth" `parseIn` markerWidth-    ,"markerHeight" `parseIn` markerHeight-    ,"patternUnits" `parseIn` markerUnits-    ,"orient" `parseIn` markerOrient-    ,"viewBox" `parseIn` markerViewBox-    ,"overflow" `parseIn` markerOverflow-    ,"preserveAspectRatio" `parseIn` markerAspectRatio-    ]--serializeText :: Text -> Maybe X.Element-serializeText topText = namedNode where-  namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode-  topNode = serializeSpan $ _textRoot topText--  serializeSpan tspan = case (info, drawInfo) of-    (Nothing, Nothing) -> Nothing-    (Just a, Nothing) -> Just $ setChildren a subContent-    (Nothing, Just b) -> Just $ setChildren b subContent-    (Just a, Just b) -> -        Just $ setChildren (mergeAttributes a b) subContent-    where-      info = genericSerializeNode $ _spanInfo tspan-      drawInfo = genericSerializeNode $ _spanDrawAttributes tspan-      subContent = catMaybes $ serializeContent <$> _spanContent tspan--  serializeContent (SpanText t) = Just . X.Text $ X.blank_cdata { X.cdData = T.unpack t }-  serializeContent (SpanTextRef _t) = Just . X.Text $ X.blank_cdata { X.cdData = "" }-  serializeContent (SpanSub sub) = X.Elem <$> serializeSpan sub--unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath)-unparseText = extractResult . go True-  where-    extractResult (a, b, _) = (a, b)--    go startStrip [] = ([], Nothing, startStrip)-    go startStrip (X.CRef _:rest) = go startStrip rest-    go startStrip (X.Elem e@(nodeName -> "tspan"):rest) =-        (SpanSub spans : trest, mpath, retStrip)-      where-        (trest, mpath, retStrip) = go restStrip rest-        (sub, _, restStrip) = go startStrip $ X.elContent e-        spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub--    go startStrip (X.Elem e@(nodeName -> "tref"):rest) =-        case attributeFinder "href" e of-          Nothing -> go startStrip rest-          Just v -> (SpanTextRef v : trest, mpath, stripRet)-            where (trest, mpath, stripRet) = go startStrip rest--    go startStrip (X.Elem e@(nodeName -> "textPath"):rest) =-        case attributeFinder "href" e of-          Nothing -> go startStrip rest-          Just v -> (tsub ++ trest, pure p, retStrp)-            where-              p = (xmlUnparse e) { _textPathName = dropSharp v }-              (trest, _, retStrp) = go restStrip rest-              (tsub, _, restStrip) = go startStrip $ X.elContent e--    go startStrip (X.Elem _:rest) = go startStrip rest-    go startStrip (X.Text t:rest)-      | T.length cleanText == 0 = go startStrip rest-      | otherwise =-        (SpanText cleanText : trest, mpath, stripRet)-       where-         (trest, mpath, stripRet) = go subShouldStrip rest--         subShouldStrip = T.pack " " `T.isSuffixOf` cleanText--         space = T.singleton ' '-         singulariseSpaces tt-            | space `T.isPrefixOf` tt = space-            | otherwise = tt--         stripStart | startStrip = T.stripStart-                    | otherwise = id--         cleanText = stripStart-                   . T.concat-                   . fmap singulariseSpaces-                   . T.groupBy (\a b -> (a /= ' ' && b /= ' ') || a == b)-                   . T.filter (\c -> c /= '\n' && c /= '\r')-                   . T.map (\c -> if c == '\t' then ' ' else c)-                   . T.pack-                   $ X.cdData t--gradientOffsetSetter :: SvgAttributeLens GradientStop-gradientOffsetSetter = SvgAttributeLens "offset" setter serialize-  where-    serialize a = Just $ printf "%d%%" percentage-      where percentage = floor . (100 *) $ a ^. gradientOffset :: Int--    setter el str = el & gradientOffset .~ val-      where-        val = realToFrac $ case parseMayStartDot complexNumber str of-            Nothing -> 0-            Just (Num n) -> n-            Just (Px n) -> n-            Just (Percent n) -> n-            Just (Em n) -> n-            Just (Pc n) -> n-            Just (Mm n) -> n-            Just (Cm n) -> n-            Just (Point n) -> n-            Just (Inches n) -> n--instance XMLUpdatable GradientStop where-    xmlTagName _ = "stop"-    serializeTreeNode = genericSerializeNode-    attributes =-        [gradientOffsetSetter-        ,opacitySetter "stop-opacity" gradientOpacity-        ,"stop-color" `parseIn` gradientColor-        ,"path" `parseIn` gradientPath-        ]---data Symbols = Symbols-  { symbols :: !(M.Map String Element)-  , cssStyle   :: [CssRule]-  }--emptyState :: Symbols-emptyState = Symbols mempty mempty--parseGradientStops :: X.Element -> [GradientStop]-parseGradientStops = concatMap unStop . elChildren-  where-    unStop e@(nodeName -> "stop") = [xmlUnparse e]-    unStop _ = []--parseMeshGradientPatches :: X.Element -> [MeshGradientPatch]-parseMeshGradientPatches = foldMap unparsePatch . elChildren where-  unparsePatch e@(nodeName -> "meshpatch") = [MeshGradientPatch $ parseGradientStops e]-  unparsePatch _ = []--parseMeshGradientRows :: X.Element -> [MeshGradientRow]-parseMeshGradientRows = foldMap unRows . elChildren where-  unRows e@(nodeName -> "meshrow") = [MeshGradientRow $ parseMeshGradientPatches e]-  unRows _ = []--withId :: X.Element -> (X.Element -> Element)-       -> State Symbols Tree-withId el f = case attributeFinder "id" el of-  Nothing -> return None-  Just elemId -> do-      modify $ \s ->-        s { symbols = M.insert elemId (f el) $ symbols s }-      return None--unparseDefs :: X.Element -> State Symbols Tree-unparseDefs e@(nodeName -> "pattern") = do-  subElements <- mapM unparse $ elChildren e-  withId e . const . ElementPattern $ pat { _patternElements = subElements}-    where-      pat = xmlUnparse e-unparseDefs e@(nodeName -> "marker") = do-  subElements <- mapM unparse $ elChildren e-  withId e . const . ElementMarker $ mark {_markerElements = subElements }-    where-      mark = xmlUnparseWithDrawAttr e-unparseDefs e@(nodeName -> "mask") = do-  children <- mapM unparse $ elChildren e-  let realChildren = filter isNotNone children-      parsedMask = xmlUnparseWithDrawAttr e-  withId e . const . ElementMask $ parsedMask { _maskContent = realChildren }--unparseDefs e@(nodeName -> "clipPath") = do-  children <- mapM unparse $ elChildren e-  let realChildren = filter isNotNone children-      parsedClip = xmlUnparseWithDrawAttr e-  withId e . const . ElementClipPath $ parsedClip { _clipPathContent = realChildren }--unparseDefs e@(nodeName -> "linearGradient") =-  withId e $ ElementLinearGradient . unparser-  where-    unparser ee =-      xmlUnparse ee & linearGradientStops .~ parseGradientStops ee--unparseDefs e@(nodeName -> "meshgradient") =-  withId e $ ElementMeshGradient . unparser-  where-    unparser ee =-      xmlUnparseWithDrawAttr ee & meshGradientRows .~ parseMeshGradientRows ee--unparseDefs e@(nodeName -> "radialGradient") =-  withId e $ ElementRadialGradient . unparser-  where-    unparser ee =-      xmlUnparse ee & radialGradientStops .~ parseGradientStops ee-unparseDefs e = do-  el <- unparse e-  withId e (const $ ElementGeometry el)--unparse :: X.Element -> State Symbols Tree-unparse e@(nodeName -> "style") = do-  case parseOnly (many1 ruleSet) . T.pack $ strContent e of-    Left _ -> return ()-    Right rules ->-      modify $ \s -> s { cssStyle = cssStyle s ++ rules }-  return None-unparse e@(nodeName -> "defs") = do-    mapM_ unparseDefs $ elChildren e-    return None-unparse e@(nodeName -> "symbol") = do-  symbolChildren <- mapM unparse $ elChildren e-  let realChildren = filter isNotNone symbolChildren-  pure . SymbolTree . Symbol $ groupNode & groupChildren .~ realChildren-  where-    groupNode :: Group Tree-    groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e--unparse e@(nodeName -> "g") = do-  children <- mapM unparse $ elChildren e-  let realChildren = filter isNotNone children--      groupNode :: Group Tree-      groupNode = xmlUnparseWithDrawAttr e--  pure $ GroupTree $ groupNode & groupChildren .~ realChildren--unparse e@(nodeName -> "text") = do-  pathWithGeometry <- pathGeomtryOf tPath-  pure . TextTree pathWithGeometry $ xmlUnparse e & textRoot .~ root-    where-      (textContent, tPath) = unparseText $ X.elContent e--      pathGeomtryOf Nothing = pure Nothing-      pathGeomtryOf (Just pathInfo) = do-        pathElem <- gets $ M.lookup (_textPathName pathInfo) . symbols-        case pathElem of-          Nothing -> pure Nothing-          Just (ElementLinearGradient _) -> pure Nothing-          Just (ElementRadialGradient _) -> pure Nothing-          Just (ElementMeshGradient _) -> pure Nothing-          Just (ElementPattern _) -> pure Nothing-          Just (ElementMask _) -> pure Nothing-          Just (ElementClipPath _) -> pure Nothing-          Just (ElementMarker _) -> pure Nothing-          Just (ElementGeometry (PathTree p)) ->-              pure . Just $ pathInfo { _textPathData = _pathDefinition p }-          Just (ElementGeometry _) -> pure Nothing--      root = TextSpan-           { _spanInfo = xmlUnparse e-           , _spanDrawAttributes = xmlUnparse e-           , _spanContent = textContent-           }--unparse e = pure $ case nodeName e of-    "image" -> ImageTree parsed-    "ellipse" -> EllipseTree parsed-    "rect" -> RectangleTree parsed-    "polyline" -> PolyLineTree parsed-    "polygon" -> PolygonTree parsed-    "circle"-> CircleTree parsed-    "line"  -> LineTree parsed-    "path" -> PathTree parsed-    "meshgradient" ->-      MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e-    "use" -> UseTree parsed Nothing-    _ -> None-  where-    parsed :: (XMLUpdatable a, WithDrawAttributes a) => a-    parsed = xmlUnparseWithDrawAttr e--unparseDocument :: FilePath -> X.Element -> Maybe Document-unparseDocument rootLocation e@(nodeName -> "svg") = Just Document-    { _viewBox =-        attributeFinder "viewBox" e >>= parse viewBoxParser-    , _elements = parsedElements-    , _width = lengthFind "width"-    , _height = lengthFind "height"-    , _definitions = symbols named-    , _description = ""-    , _styleRules = cssStyle named-    , _documentLocation = rootLocation-    }-  where-    (parsedElements, named) =-        runState (mapM unparse $ elChildren e) emptyState-    lengthFind n =-        attributeFinder n e >>= parse complexNumber-unparseDocument _ _ = Nothing---- | Transform a SVG document to a XML node.-xmlOfDocument :: Document -> X.Element-xmlOfDocument doc =-    X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ defsTag ++ children)-  where-    attr name = X.Attr (X.unqual name)-    children = catMaybes [serializeTreeNode el | el <- _elements doc]--    defsTag | null defs = []-            | otherwise = [X.node (X.unqual "defs") defs]--    defs = catMaybes [elementRender k e | (k, e) <- M.assocs $ _definitions doc]--    elementRender k e = case e of-        ElementGeometry t -> serialize t-        ElementMarker m -> serialize m-        ElementMask m -> serialize m-        ElementClipPath c -> serialize c-        ElementPattern p -> serialize p-        ElementLinearGradient lg -> addId $ serializeTreeNode lg-        ElementRadialGradient rg -> addId $ serializeTreeNode rg-        ElementMeshGradient   mg -> addId $ serializeTreeNode mg-      where-        addId = fmap (X.add_attr $ attr "id" k)--        serialize :: (WithDrawAttributes e, XMLUpdatable e) => e -> Maybe X.Element-        serialize el = case el^.drawAttr.attrId of-          Nothing -> addId $ serializeTreeNode el-          Just _id ->-            let newNode = el & drawAttr.attrId .~ Just k in-            serializeTreeNode newNode--    docViewBox = case _viewBox doc of-        Nothing -> []-        Just b -> [attr "viewBox" $ serializeViewBox b]--    descTag = case _description doc of-        "" -> []-        txt -> [X.node (X.unqual "desc") txt]--    styleTag = case _styleRules doc of-        [] -> []-        rules -> [X.node (X.unqual "style")-                        ([attr "type" "text/css"], txt)]-          where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules--    attrs =-        docViewBox ++-        [attr "xmlns" "http://www.w3.org/2000/svg"-        ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink"-        ,attr "version" "1.1"] ++-        catMaybes [attr "width" . serializeNumber <$> _width doc-                  ,attr "height" . serializeNumber <$> _height doc-                  ]-+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Graphics.Svg.XmlParser( xmlOfDocument
+                             , unparseDocument
+
+                             , SvgAttributeLens( .. )
+                             , drawAttributesList
+                             ) where
+
+
+#if !MIN_VERSION_base(4,6,0)
+import Text.Read( reads )
+#else
+import Text.Read( readMaybe )
+#endif
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( pure, (<$>), (<$), (<*>) )
+import Data.Foldable( foldMap )
+import Data.Monoid( mempty )
+#endif
+
+import Control.Applicative( (<|>), many )
+
+import Control.Lens hiding( transform, children, elements, element )
+import Control.Monad.State.Strict( State, runState, modify, gets )
+import Data.Maybe( fromMaybe, catMaybes )
+import Data.Monoid( Last( Last ), getLast, (<>) )
+import Data.List( foldl', intercalate )
+import Text.XML.Light.Proc( findAttrBy, elChildren, strContent )
+import qualified Text.XML.Light as X
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TB
+import qualified Data.Map as M
+import Data.Attoparsec.Text( Parser, string, parseOnly, many1 )
+import Codec.Picture( PixelRGBA8( .. ) )
+import Graphics.Svg.Types
+import Graphics.Svg.PathParser
+import Graphics.Svg.ColorParser
+import Graphics.Svg.CssTypes( CssDeclaration( .. )
+                            , CssElement( .. )
+                            , CssRule
+                            , tserialize
+                            )
+import Graphics.Svg.CssParser( complexNumber
+                             , num
+                             , ruleSet
+                             , dashArray
+                             , styleString
+                             , numberList )
+
+import Text.Printf( printf )
+
+{-import Debug.Trace-}
+
+#if !MIN_VERSION_base(4,6,0)
+readMaybe :: Read a => String -> Maybe a
+readMaybe str = case reads str of
+  [] -> Nothing
+  (x, _):_ -> Just x
+#endif
+
+nodeName :: X.Element -> String
+nodeName = X.qName . X.elName
+
+attributeFinder :: String -> X.Element -> Maybe String
+attributeFinder str =
+    findAttrBy (\a -> X.qName a == str)
+
+-- | Helper class to help simplify parsing code
+-- for various attributes.
+class ParseableAttribute a where
+  aparse :: String -> Maybe a
+  aserialize :: a -> Maybe String
+
+instance ParseableAttribute v => ParseableAttribute (Maybe v) where
+  aparse = fmap Just . aparse
+  aserialize = (>>= aserialize)
+
+instance ParseableAttribute v => ParseableAttribute (Last v) where
+  aparse = fmap Last . aparse
+  aserialize = aserialize . getLast
+
+instance ParseableAttribute String where
+  aparse = Just
+  aserialize = Just
+
+instance ParseableAttribute Number where
+  aparse = parseMayStartDot complexNumber
+  aserialize = Just . serializeNumber
+
+instance ParseableAttribute [Number] where
+  aparse = parse dashArray
+  aserialize = Just . serializeDashArray
+
+instance ParseableAttribute PixelRGBA8 where
+  aparse = parse colorParser
+  aserialize = Just . colorSerializer
+
+instance ParseableAttribute [PathCommand] where
+  aparse = parse pathParser
+  aserialize = Just . serializeCommands
+
+instance ParseableAttribute GradientPathCommand where
+  aparse = parse gradientCommand
+  aserialize = Just . serializeGradientCommand
+
+instance ParseableAttribute [RPoint] where
+  aparse = parse pointData
+  aserialize = Just . serializePoints
+
+instance ParseableAttribute Double where
+  aparse = parseMayStartDot num
+  aserialize v = Just $ printf "%g" v
+
+instance ParseableAttribute Texture where
+  aparse = parse textureParser
+  aserialize = Just . textureSerializer
+
+instance ParseableAttribute [Transformation] where
+  aparse = parse $ many transformParser
+  aserialize = Just . serializeTransformations
+
+instance ParseableAttribute Alignment where
+  aparse s = Just $ case s of
+    "none" -> AlignNone 
+    "xMinYMin" -> AlignxMinYMin
+    "xMidYMin" -> AlignxMidYMin
+    "xMaxYMin" -> AlignxMaxYMin
+    "xMinYMid" -> AlignxMinYMid
+    "xMidYMid" -> AlignxMidYMid
+    "xMaxYMid" -> AlignxMaxYMid
+    "xMinYMax" -> AlignxMinYMax
+    "xMidYMax" -> AlignxMidYMax
+    "xMaxYMax" -> AlignxMaxYMax
+    _ -> _aspectRatioAlign defaultSvg
+
+  aserialize v = Just $ case v of
+    AlignNone -> "none" 
+    AlignxMinYMin -> "xMinYMin"
+    AlignxMidYMin -> "xMidYMin"
+    AlignxMaxYMin -> "xMaxYMin"
+    AlignxMinYMid -> "xMinYMid"
+    AlignxMidYMid -> "xMidYMid"
+    AlignxMaxYMid -> "xMaxYMid"
+    AlignxMinYMax -> "xMinYMax"
+    AlignxMidYMax -> "xMidYMax"
+    AlignxMaxYMax -> "xMaxYMax"
+
+instance ParseableAttribute MeshGradientType where
+  aparse s = Just $ case s of
+    "bilinear" -> GradientBilinear
+    "bicubic" -> GradientBicubic
+    _ -> GradientBilinear
+  
+  aserialize v = Just $ case v of
+    GradientBilinear -> "bilinear"
+    GradientBicubic -> "bicubic"
+
+instance ParseableAttribute MeetSlice where
+  aparse s = case s of
+    "meet" -> Just Meet
+    "slice" -> Just Slice
+    _ -> Nothing
+
+  aserialize v = Just $ case v of
+    Meet -> "meet"
+    Slice -> "slice"
+
+instance ParseableAttribute PreserveAspectRatio where
+  aserialize v = Just $ defer <> align <> meetSlice where
+    defer = if _aspectRatioDefer v then "defer " else ""
+    align = fromMaybe "" . aserialize $ _aspectRatioAlign v
+    meetSlice = fromMaybe "" $ aserialize =<< _aspectRatioMeetSlice v
+
+  aparse s = case words s of
+      [] -> Nothing
+      [align] -> Just $ defaultSvg { _aspectRatioAlign = alignOf align }
+      ["defer", align] ->
+          Just $ defaultSvg
+            { _aspectRatioDefer = True
+            , _aspectRatioAlign = alignOf align
+            }
+      [align, meet] ->
+          Just $ defaultSvg
+            { _aspectRatioMeetSlice = aparse meet
+            , _aspectRatioAlign = alignOf align
+            }
+      ["defer", align, meet] ->
+          Just $ PreserveAspectRatio 
+              { _aspectRatioDefer = True
+              , _aspectRatioAlign = alignOf align
+              , _aspectRatioMeetSlice = aparse meet
+              }
+      _ -> Nothing
+    where
+      alignOf = fromMaybe (_aspectRatioAlign defaultSvg) . aparse
+
+instance ParseableAttribute Cap where
+  aparse s = case s of
+    "butt" -> Just CapButt
+    "round" -> Just CapRound
+    "square" -> Just CapSquare
+    _ -> Nothing
+
+  aserialize c = Just $ case c of
+    CapButt -> "butt"
+    CapRound -> "round"
+    CapSquare -> "square"
+
+instance ParseableAttribute TextAnchor where
+  aparse s = case s of
+    "middle" -> Just TextAnchorMiddle
+    "start" -> Just TextAnchorStart
+    "end" -> Just TextAnchorEnd
+    _ -> Nothing
+
+  aserialize t = Just $ case t of
+    TextAnchorMiddle -> "middle"
+    TextAnchorStart -> "start"
+    TextAnchorEnd -> "end"
+
+instance ParseableAttribute ElementRef where
+  aparse s = case parseOnly pa $ T.pack s of
+     Left _ -> Nothing
+     Right v -> Just v
+    where
+      pa = (RefNone <$ string "none")
+        <|> (Ref <$> urlRef)
+
+  aserialize c = Just $ case c of
+    Ref r -> "url(#" <> r <> ")"
+    RefNone -> "none"
+
+instance ParseableAttribute LineJoin where
+  aparse s = case s of
+    "miter" -> Just JoinMiter
+    "round" -> Just JoinRound
+    "bevel" -> Just JoinBevel
+    _ -> Nothing
+
+  aserialize j = Just $ case j of
+    JoinMiter -> "miter"
+    JoinRound -> "round"
+    JoinBevel -> "bevel"
+
+instance ParseableAttribute CoordinateUnits where
+  aparse s = case s of
+    "userSpaceOnUse" -> Just CoordUserSpace
+    "objectBoundingBox" -> Just CoordBoundingBox
+    _ -> Just CoordBoundingBox
+
+  aserialize uni = Just $ case uni of
+    CoordUserSpace -> "userSpaceOnUse"
+    CoordBoundingBox -> "objectBoundingBox"
+
+instance ParseableAttribute Spread where
+  aparse s = case s of
+    "pad" -> Just SpreadPad
+    "reflect" -> Just SpreadReflect
+    "repeat" -> Just SpreadRepeat
+    _ -> Nothing
+
+  aserialize s = Just $ case s of
+    SpreadPad -> "pad"
+    SpreadReflect -> "reflect"
+    SpreadRepeat -> "repeat"
+
+instance ParseableAttribute FillRule where
+  aparse s = case s of
+    "nonzero" -> Just FillNonZero
+    "evenodd" -> Just FillEvenOdd
+    _ -> Nothing
+
+  aserialize f = Just $ case f of
+    FillNonZero -> "nonzero"
+    FillEvenOdd -> "evenodd"
+
+instance ParseableAttribute TextAdjust where
+  aparse s = Just $ case s of
+    "spacing" -> TextAdjustSpacing
+    "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs
+    _ -> TextAdjustSpacing
+
+  aserialize a = Just $ case a of
+    TextAdjustSpacing -> "spacing"
+    TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs"
+
+instance ParseableAttribute MarkerUnit where
+  aparse s = case s of
+    "strokeWidth" -> Just MarkerUnitStrokeWidth
+    "userSpaceOnUse" -> Just MarkerUnitUserSpaceOnUse
+    _ -> Nothing
+
+  aserialize u = Just $ case u of
+    MarkerUnitStrokeWidth -> "strokeWidth"
+    MarkerUnitUserSpaceOnUse -> "userSpaceOnUse"
+
+instance ParseableAttribute Overflow where
+  aparse s = case s of
+    "visible" -> Just OverflowVisible
+    "hidden" -> Just OverflowHidden
+    _ -> Nothing
+
+  aserialize u = Just $ case u of
+    OverflowVisible -> "visible"
+    OverflowHidden -> "hidden"
+
+instance ParseableAttribute MarkerOrientation where
+  aparse s = case (s, readMaybe s) of
+    ("auto", _) -> Just OrientationAuto
+    (_, Just f) -> Just $ OrientationAngle f
+    _ -> Nothing
+
+  aserialize s = Just $ case s of
+    OrientationAuto -> "auto"
+    OrientationAngle f -> show f
+
+instance ParseableAttribute (Double, Double, Double, Double) where
+  aparse = parse viewBoxParser
+  aserialize = Just . serializeViewBox
+
+instance ParseableAttribute TextPathMethod where
+  aparse s = case s of
+    "align" -> Just TextPathAlign
+    "stretch" -> Just TextPathStretch
+    _ -> Nothing
+  aserialize m = Just $ case m of
+    TextPathAlign -> "align"
+    TextPathStretch -> "stretch"
+
+instance ParseableAttribute TextPathSpacing where
+  aparse s = case s of
+    "auto" -> Just TextPathSpacingAuto
+    "exact" -> Just TextPathSpacingExact
+    _ -> Nothing
+
+  aserialize s = Just $ case s of
+    TextPathSpacingAuto -> "auto"
+    TextPathSpacingExact -> "exact"
+
+parse :: Parser a -> String -> Maybe a
+parse p str = case parseOnly p (T.pack str) of
+  Left _ -> Nothing
+  Right r -> Just r
+
+parseMayStartDot :: Parser a -> String -> Maybe a
+parseMayStartDot p l@('.':_) = parse p ('0':l)
+parseMayStartDot p l = parse p l
+
+xmlUpdate :: (XMLUpdatable a) => a -> X.Element -> a
+xmlUpdate initial el = foldl' grab initial attributes
+  where
+    grab value updater =
+        case attributeFinder (_attributeName updater) el of
+          Nothing -> value
+          Just v -> _attributeUpdater updater value v
+
+xmlUnparse :: (XMLUpdatable a) => X.Element -> a
+xmlUnparse = xmlUpdate defaultSvg
+
+xmlUnparseWithDrawAttr
+    :: (XMLUpdatable a, WithDrawAttributes a)
+    => X.Element -> a
+xmlUnparseWithDrawAttr e =
+    xmlUnparse e & drawAttr .~ xmlUnparse e
+
+data SvgAttributeLens t = SvgAttributeLens
+  { _attributeName       :: String
+  , _attributeUpdater    :: t -> String -> t
+  , _attributeSerializer :: t -> Maybe String
+  }
+
+class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where
+  xmlTagName :: treeNode -> String
+  attributes :: [SvgAttributeLens treeNode]
+
+  serializeTreeNode :: treeNode -> Maybe X.Element
+
+setChildren :: X.Element -> [X.Content] -> X.Element
+setChildren xNode children = xNode { X.elContent = children }
+
+updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> Maybe X.Element -> Maybe X.Element
+updateWithAccessor        _    _ Nothing = Nothing
+updateWithAccessor accessor node (Just xNode) =
+    Just . setChildren xNode . fmap  X.Elem . catMaybes $ serializeTreeNode <$> accessor node
+
+genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> Maybe X.Element
+genericSerializeNode node =
+    Just . X.unode (xmlTagName node) $ concatMap generateAttribute attributes
+  where
+    generateAttribute attr = case _attributeSerializer attr node of
+      Nothing -> []
+      Just str -> return X.Attr
+        { X.attrKey = xName $ _attributeName attr
+        , X.attrVal = str
+        }
+        where
+         xName "href" =
+            X.QName { X.qName = "href"
+                    , X.qURI = Nothing
+                    , X.qPrefix = Just "xlink" }
+         xName h = X.unqual h
+
+
+mergeAttributes :: X.Element -> X.Element -> X.Element
+mergeAttributes thisXml otherXml =
+    thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml }
+
+genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode)
+                             => treeNode -> Maybe X.Element
+genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where
+  thisXml = genericSerializeNode node
+  drawAttrNode = genericSerializeNode $ node ^. drawAttr
+
+type CssUpdater a =
+    a -> [[CssElement]] -> a
+
+opacitySetter :: String -> Lens' a (Maybe Float) -> SvgAttributeLens a
+opacitySetter attribute elLens =
+    SvgAttributeLens attribute updater serializer
+  where
+    serializer a = printf "%g" <$> a ^. elLens
+    updater el str = case parseMayStartDot num str of
+        Nothing -> el
+        Just v -> el & elLens .~ Just (realToFrac v)
+
+type Serializer e = e -> Maybe String
+
+parserSetter :: String -> Lens' a e -> (String -> Maybe e) -> Serializer e
+             -> SvgAttributeLens a
+parserSetter attribute elLens parser serialize =
+    SvgAttributeLens attribute updater serializer
+  where
+    updater el str = case parser str of
+        Nothing -> el
+        Just v -> el & elLens .~ v
+
+    serializer  a = serialize $ a ^. elLens
+
+parseIn :: (Eq a, WithDefaultSvg s, ParseableAttribute a)
+        => String -> Lens' s a -> SvgAttributeLens s
+parseIn attribute elLens =
+    SvgAttributeLens attribute updater serializer
+  where
+    updater el str = case aparse str of
+        Nothing -> el
+        Just v -> el & elLens .~ v
+
+    serializer a
+      | v /= defaultVal = aserialize v
+      | otherwise = Nothing
+      where
+        v = a ^. elLens
+        defaultVal = defaultSvg ^. elLens
+
+parserLastSetter :: String -> Lens' a (Last e) -> (String -> Maybe e) -> Serializer e
+                 -> SvgAttributeLens a
+parserLastSetter attribute elLens parser serialize =
+    SvgAttributeLens attribute updater serializer
+  where
+    updater el str = case parser str of
+        Nothing -> el
+        Just v -> el & elLens .~ Last (Just v)
+
+    serializer a = getLast (a ^. elLens) >>= serialize
+
+classSetter :: SvgAttributeLens DrawAttributes
+classSetter = SvgAttributeLens "class" updater serializer
+  where
+    updater el str =
+      el & attrClass .~ (T.split (== ' ') $ T.pack str)
+
+    serializer a = case a ^. attrClass of
+      [] -> Nothing
+      lst -> Just . T.unpack $ T.intercalate " " lst
+
+cssUniqueNumber :: ASetter el el
+                   a (Last Number)
+                -> CssUpdater el
+cssUniqueNumber setter attr ((CssNumber n:_):_) =
+    attr & setter .~ Last (Just n)
+cssUniqueNumber _ attr _ = attr
+
+cssUniqueFloat :: (Fractional n)
+               => ASetter el el a (Maybe n)
+               -> CssUpdater el
+cssUniqueFloat setter attr ((CssNumber (Num n):_):_) =
+    attr & setter .~ Just (realToFrac n)
+cssUniqueFloat _ attr _ = attr
+
+cssUniqueMayFloat :: ASetter el el a (Last Double)
+               -> CssUpdater el
+cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) =
+    attr & setter .~ Last (Just n)
+cssUniqueMayFloat _ attr _ = attr
+
+cssIdentAttr :: ParseableAttribute a => Lens' el a -> CssUpdater el
+cssIdentAttr setter attr ((CssIdent i:_):_) = case aparse $ T.unpack i of
+    Nothing -> attr
+    Just v -> attr & setter .~ v
+cssIdentAttr _ attr _ = attr
+
+fontFamilyParser :: CssUpdater DrawAttributes
+fontFamilyParser attr (lst:_) = attr & fontFamily .~ fontNames
+  where
+    fontNames = Last . Just $ T.unpack <$> extractString lst
+
+    extractString [] = []
+    extractString (CssIdent n:rest) = n : extractString rest
+    extractString (CssString n:rest) = n : extractString rest
+    extractString (_:rest) = extractString rest
+fontFamilyParser attr _ = attr
+
+
+cssUniqueTexture :: ASetter el el
+                    a (Last Texture)
+                 -> CssUpdater el
+cssUniqueTexture setter attr css = case css of
+  ((CssIdent "none":_):_) -> attr & setter .~ Last (Just FillNone)
+  ((CssColor c:_):_) -> attr & setter .~ Last (Just $ ColorRef c)
+  ((CssFunction "url" [CssReference c]:_):_) ->
+        attr & setter .~ Last (Just . TextureRef $ T.unpack c)
+  _ -> attr
+
+cssUniqueColor :: ASetter el el a PixelRGBA8 -> CssUpdater el
+cssUniqueColor setter attr css = case css of
+  ((CssColor c:_):_) -> attr & setter .~ c
+  _ -> attr
+
+cssElementRefSetter :: Lens' el (Last ElementRef) -> CssUpdater el
+cssElementRefSetter setter attr ((CssFunction "url" [CssReference c]:_):_) =
+    attr & setter .~ Last (Just . Ref $ T.unpack c)
+cssElementRefSetter setter attr ((CssIdent "none":_):_) =
+    attr & setter .~ Last (Just RefNone)
+cssElementRefSetter _ attr _ = attr
+
+cssMayStringSetter :: ASetter el el a (Maybe String) -> CssUpdater el
+cssMayStringSetter setter attr ((CssIdent i:_):_) =
+    attr & setter .~ Just (T.unpack i)
+cssMayStringSetter setter attr ((CssString i:_):_) =
+    attr & setter .~ Just (T.unpack i)
+cssMayStringSetter _ attr _ = attr
+
+cssNullSetter :: CssUpdater a
+cssNullSetter attr _ = attr
+
+cssDashArray :: ASetter el el a (Last [Number]) -> CssUpdater el
+cssDashArray setter attr (lst:_) =
+  case [n | CssNumber n <- lst ] of
+    [] -> attr
+    v -> attr & setter .~ Last (Just v)
+cssDashArray _ attr _ = attr
+
+
+drawAttributesList :: [(SvgAttributeLens DrawAttributes, CssUpdater DrawAttributes)]
+drawAttributesList =
+  [("stroke-width" `parseIn` strokeWidth, cssUniqueNumber strokeWidth)
+  ,("stroke" `parseIn` strokeColor, cssUniqueTexture strokeColor)
+  ,("fill" `parseIn` fillColor, cssUniqueTexture fillColor)
+  ,("stroke-linecap" `parseIn` strokeLineCap, cssIdentAttr strokeLineCap)
+  ,("stroke-linejoin" `parseIn` strokeLineJoin, cssIdentAttr strokeLineJoin)
+  ,("stroke-miterlimit" `parseIn` strokeMiterLimit,
+       cssUniqueMayFloat strokeMiterLimit)
+
+  ,("transform" `parseIn` transform, const)
+  ,(opacitySetter "opacity" groupOpacity, cssUniqueFloat groupOpacity)
+  ,(opacitySetter "fill-opacity" fillOpacity, cssUniqueFloat fillOpacity)
+  ,(opacitySetter "stroke-opacity" strokeOpacity, cssUniqueFloat strokeOpacity)
+  ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize)
+  ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate)
+      (Just . intercalate ", "), fontFamilyParser)
+
+  ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule)
+  ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule)
+  ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef)
+  ,(classSetter, cssNullSetter) -- can't set class in CSS
+  ,("id" `parseIn` attrId, cssMayStringSetter attrId)
+  ,("stroke-dashoffset" `parseIn` strokeOffset,
+      cssUniqueNumber strokeOffset)
+  ,("stroke-dasharray" `parseIn` strokeDashArray, cssDashArray strokeDashArray)
+  ,("text-anchor" `parseIn` textAnchor, cssIdentAttr textAnchor)
+  ,("clip-path" `parseIn` clipPathRef, cssElementRefSetter clipPathRef)
+  ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd)
+  ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart)
+  ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid)
+  ]
+  where
+    commaSeparate =
+        fmap (T.unpack . T.strip) . T.split (',' ==) . T.pack
+
+serializeDashArray :: [Number] -> String
+serializeDashArray =
+   intercalate ", " . fmap serializeNumber
+
+instance XMLUpdatable DrawAttributes where
+  xmlTagName _ = "DRAWATTRIBUTES"
+  attributes =
+      styleAttribute drawAttributesList : fmap fst drawAttributesList
+  serializeTreeNode = genericSerializeNode
+
+styleAttribute :: [(SvgAttributeLens a, CssUpdater a)] -> SvgAttributeLens a
+styleAttribute styleAttrs = SvgAttributeLens
+  { _attributeName       = "style"
+  , _attributeUpdater    = updater
+  , _attributeSerializer = const Nothing
+  }
+  where
+    updater attrs style = case parse styleString style of
+        Nothing -> attrs
+        Just decls -> foldl' applyer attrs decls
+
+    cssUpdaters = [(T.pack $ _attributeName n, u) | (n, u) <- styleAttrs]
+    applyer value (CssDeclaration txt elems) =
+        case lookup txt cssUpdaters of
+          Nothing -> value
+          Just f -> f value elems
+
+instance XMLUpdatable Rectangle where
+  xmlTagName _ = "rect"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes =
+    ["width" `parseIn` rectWidth
+    ,"height" `parseIn` rectHeight
+    ,"x" `parseIn` (rectUpperLeftCorner._1)
+    ,"y" `parseIn` (rectUpperLeftCorner._2)
+    ,"rx" `parseIn` (rectCornerRadius._1)
+    ,"ry" `parseIn` (rectCornerRadius._2)
+    ]
+
+instance XMLUpdatable Image where
+  xmlTagName _ = "image"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes =
+    ["width" `parseIn` imageWidth
+    ,"height" `parseIn` imageHeight
+    ,"x" `parseIn` (imageCornerUpperLeft._1)
+    ,"y" `parseIn` (imageCornerUpperLeft._2)
+    ,parserSetter "href" imageHref (Just . dropSharp) Just
+    ,"preserveAspectRatio" `parseIn` imageAspectRatio
+    ]
+
+instance XMLUpdatable Line where
+  xmlTagName _ = "line"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes =
+    ["x1" `parseIn` (linePoint1._1)
+    ,"y1" `parseIn` (linePoint1._2)
+    ,"x2" `parseIn` (linePoint2._1)
+    ,"y2" `parseIn` (linePoint2._2)
+    ]
+
+instance XMLUpdatable Ellipse where
+  xmlTagName _ = "ellipse"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes =
+    ["cx" `parseIn` (ellipseCenter._1)
+    ,"cy" `parseIn` (ellipseCenter._2)
+    ,"rx" `parseIn` ellipseXRadius
+    ,"ry" `parseIn` ellipseYRadius
+    ]
+
+instance XMLUpdatable Circle where
+  xmlTagName _ = "circle"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes =
+    ["cx" `parseIn` (circleCenter._1)
+    ,"cy" `parseIn` (circleCenter._2)
+    ,"r" `parseIn` circleRadius
+    ]
+
+instance XMLUpdatable Mask where
+  xmlTagName _ = "mask"
+  serializeTreeNode node =
+      updateWithAccessor _maskContent node $
+          genericSerializeWithDrawAttr node
+
+  attributes =
+    ["x" `parseIn` (maskPosition._1)
+    ,"y" `parseIn` (maskPosition._2)
+    ,"width" `parseIn` maskWidth
+    ,"height" `parseIn` maskHeight
+    ,"maskContentUnits" `parseIn` maskContentUnits
+    ,"maskUnits" `parseIn` maskUnits
+    ]
+
+instance XMLUpdatable ClipPath where
+  xmlTagName _ = "clipPath"
+  serializeTreeNode node =
+      updateWithAccessor _clipPathContent node $
+          genericSerializeWithDrawAttr node
+  attributes =
+    ["clipPathUnits" `parseIn` clipPathUnits]
+
+instance XMLUpdatable Polygon where
+  xmlTagName _ = "polygon"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes = ["points" `parseIn` polygonPoints]
+
+instance XMLUpdatable PolyLine where
+  xmlTagName _ =  "polyline"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes = ["points" `parseIn` polyLinePoints]
+
+instance XMLUpdatable Path where
+  xmlTagName _ =  "path"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes = ["d" `parseIn` pathDefinition]
+
+instance XMLUpdatable MeshGradientPatch where
+  xmlTagName _ = "meshpatch"
+  attributes = []
+  serializeTreeNode node =
+     updateWithAccessor _meshGradientPatchStops node $ genericSerializeNode node
+
+instance XMLUpdatable MeshGradientRow where
+  xmlTagName _ = "meshrow"
+  serializeTreeNode node =
+     updateWithAccessor _meshGradientRowPatches node $ genericSerializeNode node
+  attributes = []
+
+instance XMLUpdatable MeshGradient where
+  xmlTagName _ = "meshgradient"
+  serializeTreeNode node =
+     updateWithAccessor _meshGradientRows node $ genericSerializeWithDrawAttr node
+  attributes =
+    ["x" `parseIn` meshGradientX
+    ,"y" `parseIn` meshGradientY
+    ,"type" `parseIn` meshGradientType
+    ,"gradientUnits" `parseIn` meshGradientUnits
+    ,"gradientTransform" `parseIn` meshGradientTransform
+    ]
+
+
+instance XMLUpdatable LinearGradient where
+  xmlTagName _ = "linearGradient"
+  serializeTreeNode node =
+     updateWithAccessor _linearGradientStops node $ genericSerializeNode node
+
+  attributes =
+    ["gradientTransform" `parseIn` linearGradientTransform
+    ,"gradientUnits" `parseIn` linearGradientUnits
+    ,"spreadMethod" `parseIn` linearGradientSpread
+    ,"x1" `parseIn` (linearGradientStart._1)
+    ,"y1" `parseIn` (linearGradientStart._2)
+    ,"x2" `parseIn` (linearGradientStop._1)
+    ,"y2" `parseIn` (linearGradientStop._2)
+    ]
+
+instance XMLUpdatable Tree where
+  xmlTagName _ = "TREE"
+  attributes = []
+  serializeTreeNode e = case e of
+    None -> Nothing
+    UseTree u _ -> serializeTreeNode u
+    GroupTree g -> serializeTreeNode g
+    SymbolTree s -> serializeTreeNode s
+    PathTree p -> serializeTreeNode p
+    CircleTree c -> serializeTreeNode c
+    PolyLineTree p -> serializeTreeNode p
+    PolygonTree p -> serializeTreeNode p
+    EllipseTree el -> serializeTreeNode el
+    LineTree l -> serializeTreeNode l
+    RectangleTree r -> serializeTreeNode r
+    TextTree Nothing t -> serializeTreeNode t
+    ImageTree i -> serializeTreeNode i
+    MeshGradientTree m -> serializeTreeNode m
+    TextTree (Just p) t -> do
+       textNode <- serializeTreeNode t
+       pathNode <- serializeTreeNode p
+       let sub = [X.Elem . setChildren pathNode $ X.elContent textNode]
+       return $ setChildren textNode sub
+
+
+isNotNone :: Tree -> Bool
+isNotNone None = False
+isNotNone _ = True
+
+instance XMLUpdatable (Group Tree) where
+  xmlTagName _ = "g"
+  serializeTreeNode node =
+     updateWithAccessor (filter isNotNone . _groupChildren) node $
+        genericSerializeWithDrawAttr node
+  attributes = []
+
+instance XMLUpdatable (Symbol Tree) where
+  xmlTagName _ = "symbol"
+  serializeTreeNode node =
+     updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $
+        genericSerializeWithDrawAttr node
+  attributes =
+     ["viewBox" `parseIn` (groupOfSymbol . groupViewBox)
+     ,"preserveAspectRatio" `parseIn` (groupOfSymbol . groupAspectRatio)
+     ]
+
+
+instance XMLUpdatable RadialGradient where
+  xmlTagName _ = "radialGradient"
+  serializeTreeNode node =
+     updateWithAccessor _radialGradientStops node $ genericSerializeNode node
+  attributes =
+    ["gradientTransform" `parseIn` radialGradientTransform
+    ,"gradientUnits" `parseIn` radialGradientUnits
+    ,"spreadMethod" `parseIn` radialGradientSpread
+    ,"cx" `parseIn` (radialGradientCenter._1)
+    ,"cy" `parseIn` (radialGradientCenter._2)
+    ,"r"  `parseIn` radialGradientRadius
+    ,"fx" `parseIn` radialGradientFocusX
+    ,"fy" `parseIn` radialGradientFocusY
+    ]
+
+instance XMLUpdatable Use where
+  xmlTagName _ = "use"
+  serializeTreeNode = genericSerializeWithDrawAttr
+  attributes =
+    ["x" `parseIn` (useBase._1)
+    ,"y" `parseIn` (useBase._2)
+    ,"width" `parseIn` useWidth
+    ,"height" `parseIn` useHeight
+    ,parserSetter "href" useName (Just . dropSharp) (Just . ('#':))
+    ]
+
+dropSharp :: String -> String
+dropSharp ('#':rest) = rest
+dropSharp a = a
+
+instance XMLUpdatable TextInfo where
+  xmlTagName _ = "tspan"
+  serializeTreeNode = genericSerializeNode
+  attributes =
+    [parserSetter "x" textInfoX (parse dashArray) dashNotEmpty
+    ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty
+    ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty
+    ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty
+    ,parserSetter "rotate" textInfoRotate
+        (parse numberList)
+        rotateNotEmpty
+    ,"textLength" `parseIn` textInfoLength
+    ]
+    where
+      dashNotEmpty [] = Nothing
+      dashNotEmpty lst = Just $ serializeDashArray lst
+
+      rotateNotEmpty [] = Nothing
+      rotateNotEmpty lst =
+          Just . unwords $ printf "%g" <$> lst
+
+
+instance XMLUpdatable TextPath where
+  xmlTagName _ =  "textPath"
+  serializeTreeNode = genericSerializeNode
+  attributes =
+    ["startOffset" `parseIn` textPathStartOffset
+    ,"method" `parseIn` textPathMethod
+    ,"spacing" `parseIn` textPathSpacing
+    ,parserSetter "href" textPathName (Just . dropSharp) (Just . ('#':))
+    ]
+
+instance XMLUpdatable Text where
+  xmlTagName _ = "text"
+  serializeTreeNode = serializeText
+  attributes = ["lengthAdjust" `parseIn` textAdjust]
+
+
+instance XMLUpdatable Pattern where
+  xmlTagName _ = "pattern"
+  serializeTreeNode node =
+     updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node
+  attributes =
+    ["viewBox" `parseIn` patternViewBox
+    ,"patternUnits" `parseIn` patternUnit
+    ,"width" `parseIn` patternWidth
+    ,"height" `parseIn` patternHeight
+    ,"x" `parseIn` (patternPos._1)
+    ,"y" `parseIn` (patternPos._2)
+    ,"preserveAspectRatio" `parseIn` patternAspectRatio
+    ,parserSetter "href" patternHref (Just . dropSharp) (Just . ('#':))
+    ,"patternTransform" `parseIn` patternTransform
+    ]
+
+instance XMLUpdatable Marker where
+  xmlTagName _ = "marker"
+  serializeTreeNode node =
+     updateWithAccessor _markerElements node $ genericSerializeWithDrawAttr node
+  attributes =
+    ["refX" `parseIn` (markerRefPoint._1)
+    ,"refY" `parseIn` (markerRefPoint._2)
+    ,"markerWidth" `parseIn` markerWidth
+    ,"markerHeight" `parseIn` markerHeight
+    ,"patternUnits" `parseIn` markerUnits
+    ,"orient" `parseIn` markerOrient
+    ,"viewBox" `parseIn` markerViewBox
+    ,"overflow" `parseIn` markerOverflow
+    ,"preserveAspectRatio" `parseIn` markerAspectRatio
+    ]
+
+serializeText :: Text -> Maybe X.Element
+serializeText topText = namedNode where
+  namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode
+  topNode = serializeSpan $ _textRoot topText
+
+  serializeSpan tspan = case (info, drawInfo) of
+    (Nothing, Nothing) -> Nothing
+    (Just a, Nothing) -> Just $ setChildren a subContent
+    (Nothing, Just b) -> Just $ setChildren b subContent
+    (Just a, Just b) -> 
+        Just $ setChildren (mergeAttributes a b) subContent
+    where
+      info = genericSerializeNode $ _spanInfo tspan
+      drawInfo = genericSerializeNode $ _spanDrawAttributes tspan
+      subContent = catMaybes $ serializeContent <$> _spanContent tspan
+
+  serializeContent (SpanText t) = Just . X.Text $ X.blank_cdata { X.cdData = T.unpack t }
+  serializeContent (SpanTextRef _t) = Just . X.Text $ X.blank_cdata { X.cdData = "" }
+  serializeContent (SpanSub sub) = X.Elem <$> serializeSpan sub
+
+unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath)
+unparseText = extractResult . go True
+  where
+    extractResult (a, b, _) = (a, b)
+
+    go startStrip [] = ([], Nothing, startStrip)
+    go startStrip (X.CRef _:rest) = go startStrip rest
+    go startStrip (X.Elem e@(nodeName -> "tspan"):rest) =
+        (SpanSub spans : trest, mpath, retStrip)
+      where
+        (trest, mpath, retStrip) = go restStrip rest
+        (sub, _, restStrip) = go startStrip $ X.elContent e
+        spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub
+
+    go startStrip (X.Elem e@(nodeName -> "tref"):rest) =
+        case attributeFinder "href" e of
+          Nothing -> go startStrip rest
+          Just v -> (SpanTextRef v : trest, mpath, stripRet)
+            where (trest, mpath, stripRet) = go startStrip rest
+
+    go startStrip (X.Elem e@(nodeName -> "textPath"):rest) =
+        case attributeFinder "href" e of
+          Nothing -> go startStrip rest
+          Just v -> (tsub ++ trest, pure p, retStrp)
+            where
+              p = (xmlUnparse e) { _textPathName = dropSharp v }
+              (trest, _, retStrp) = go restStrip rest
+              (tsub, _, restStrip) = go startStrip $ X.elContent e
+
+    go startStrip (X.Elem _:rest) = go startStrip rest
+    go startStrip (X.Text t:rest)
+      | T.length cleanText == 0 = go startStrip rest
+      | otherwise =
+        (SpanText cleanText : trest, mpath, stripRet)
+       where
+         (trest, mpath, stripRet) = go subShouldStrip rest
+
+         subShouldStrip = T.pack " " `T.isSuffixOf` cleanText
+
+         space = T.singleton ' '
+         singulariseSpaces tt
+            | space `T.isPrefixOf` tt = space
+            | otherwise = tt
+
+         stripStart | startStrip = T.stripStart
+                    | otherwise = id
+
+         cleanText = stripStart
+                   . T.concat
+                   . fmap singulariseSpaces
+                   . T.groupBy (\a b -> (a /= ' ' && b /= ' ') || a == b)
+                   . T.filter (\c -> c /= '\n' && c /= '\r')
+                   . T.map (\c -> if c == '\t' then ' ' else c)
+                   . T.pack
+                   $ X.cdData t
+
+gradientOffsetSetter :: SvgAttributeLens GradientStop
+gradientOffsetSetter = SvgAttributeLens "offset" setter serialize
+  where
+    serialize a = Just $ printf "%d%%" percentage
+      where percentage = floor . (100 *) $ a ^. gradientOffset :: Int
+
+    setter el str = el & gradientOffset .~ val
+      where
+        val = realToFrac $ case parseMayStartDot complexNumber str of
+            Nothing -> 0
+            Just (Num n) -> n
+            Just (Px n) -> n
+            Just (Percent n) -> n
+            Just (Em n) -> n
+            Just (Pc n) -> n
+            Just (Mm n) -> n
+            Just (Cm n) -> n
+            Just (Point n) -> n
+            Just (Inches n) -> n
+
+instance XMLUpdatable GradientStop where
+    xmlTagName _ = "stop"
+    serializeTreeNode = genericSerializeNode
+    attributes = styleAttribute cssAvailable : fmap fst cssAvailable ++ lst where
+      cssAvailable :: [(SvgAttributeLens GradientStop, CssUpdater GradientStop)]
+      cssAvailable =
+          [(opacitySetter "stop-opacity" gradientOpacity, (cssUniqueFloat gradientOpacity))
+          ,("stop-color" `parseIn` gradientColor, cssUniqueColor gradientColor)
+          ]
+      
+      lst =
+        [gradientOffsetSetter
+        ,"path" `parseIn` gradientPath
+        ]
+
+
+data Symbols = Symbols
+  { symbols :: !(M.Map String Element)
+  , cssStyle   :: [CssRule]
+  }
+
+emptyState :: Symbols
+emptyState = Symbols mempty mempty
+
+parseGradientStops :: X.Element -> [GradientStop]
+parseGradientStops = concatMap unStop . elChildren
+  where
+    unStop e@(nodeName -> "stop") = [xmlUnparse e]
+    unStop _ = []
+
+parseMeshGradientPatches :: X.Element -> [MeshGradientPatch]
+parseMeshGradientPatches = foldMap unparsePatch . elChildren where
+  unparsePatch e@(nodeName -> "meshpatch") = [MeshGradientPatch $ parseGradientStops e]
+  unparsePatch _ = []
+
+parseMeshGradientRows :: X.Element -> [MeshGradientRow]
+parseMeshGradientRows = foldMap unRows . elChildren where
+  unRows e@(nodeName -> "meshrow") = [MeshGradientRow $ parseMeshGradientPatches e]
+  unRows _ = []
+
+withId :: X.Element -> (X.Element -> Element)
+       -> State Symbols Tree
+withId el f = case attributeFinder "id" el of
+  Nothing -> return None
+  Just elemId -> do
+      modify $ \s ->
+        s { symbols = M.insert elemId (f el) $ symbols s }
+      return None
+
+unparseDefs :: X.Element -> State Symbols Tree
+unparseDefs e@(nodeName -> "pattern") = do
+  subElements <- mapM unparse $ elChildren e
+  withId e . const . ElementPattern $ pat { _patternElements = subElements}
+    where
+      pat = xmlUnparse e
+unparseDefs e@(nodeName -> "marker") = do
+  subElements <- mapM unparse $ elChildren e
+  withId e . const . ElementMarker $ mark {_markerElements = subElements }
+    where
+      mark = xmlUnparseWithDrawAttr e
+unparseDefs e@(nodeName -> "mask") = do
+  children <- mapM unparse $ elChildren e
+  let realChildren = filter isNotNone children
+      parsedMask = xmlUnparseWithDrawAttr e
+  withId e . const . ElementMask $ parsedMask { _maskContent = realChildren }
+
+unparseDefs e@(nodeName -> "clipPath") = do
+  children <- mapM unparse $ elChildren e
+  let realChildren = filter isNotNone children
+      parsedClip = xmlUnparseWithDrawAttr e
+  withId e . const . ElementClipPath $ parsedClip { _clipPathContent = realChildren }
+
+unparseDefs e@(nodeName -> "linearGradient") =
+  withId e $ ElementLinearGradient . unparser
+  where
+    unparser ee =
+      xmlUnparse ee & linearGradientStops .~ parseGradientStops ee
+
+unparseDefs e@(nodeName -> "meshgradient") =
+  withId e $ ElementMeshGradient . unparser
+  where
+    unparser ee =
+      xmlUnparseWithDrawAttr ee & meshGradientRows .~ parseMeshGradientRows ee
+
+unparseDefs e@(nodeName -> "radialGradient") =
+  withId e $ ElementRadialGradient . unparser
+  where
+    unparser ee =
+      xmlUnparse ee & radialGradientStops .~ parseGradientStops ee
+unparseDefs e = do
+  el <- unparse e
+  withId e (const $ ElementGeometry el)
+
+unparse :: X.Element -> State Symbols Tree
+unparse e@(nodeName -> "style") = do
+  case parseOnly (many1 ruleSet) . T.pack $ strContent e of
+    Left _ -> return ()
+    Right rules ->
+      modify $ \s -> s { cssStyle = cssStyle s ++ rules }
+  return None
+unparse e@(nodeName -> "defs") = do
+    mapM_ unparseDefs $ elChildren e
+    return None
+unparse e@(nodeName -> "symbol") = do
+  symbolChildren <- mapM unparse $ elChildren e
+  let realChildren = filter isNotNone symbolChildren
+  pure . SymbolTree . Symbol $ groupNode & groupChildren .~ realChildren
+  where
+    groupNode :: Group Tree
+    groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e
+
+unparse e@(nodeName -> "g") = do
+  children <- mapM unparse $ elChildren e
+  let realChildren = filter isNotNone children
+
+      groupNode :: Group Tree
+      groupNode = xmlUnparseWithDrawAttr e
+
+  pure $ GroupTree $ groupNode & groupChildren .~ realChildren
+
+unparse e@(nodeName -> "text") = do
+  pathWithGeometry <- pathGeomtryOf tPath
+  pure . TextTree pathWithGeometry $ xmlUnparse e & textRoot .~ root
+    where
+      (textContent, tPath) = unparseText $ X.elContent e
+
+      pathGeomtryOf Nothing = pure Nothing
+      pathGeomtryOf (Just pathInfo) = do
+        pathElem <- gets $ M.lookup (_textPathName pathInfo) . symbols
+        case pathElem of
+          Nothing -> pure Nothing
+          Just (ElementLinearGradient _) -> pure Nothing
+          Just (ElementRadialGradient _) -> pure Nothing
+          Just (ElementMeshGradient _) -> pure Nothing
+          Just (ElementPattern _) -> pure Nothing
+          Just (ElementMask _) -> pure Nothing
+          Just (ElementClipPath _) -> pure Nothing
+          Just (ElementMarker _) -> pure Nothing
+          Just (ElementGeometry (PathTree p)) ->
+              pure . Just $ pathInfo { _textPathData = _pathDefinition p }
+          Just (ElementGeometry _) -> pure Nothing
+
+      root = TextSpan
+           { _spanInfo = xmlUnparse e
+           , _spanDrawAttributes = xmlUnparse e
+           , _spanContent = textContent
+           }
+
+unparse e = pure $ case nodeName e of
+    "image" -> ImageTree parsed
+    "ellipse" -> EllipseTree parsed
+    "rect" -> RectangleTree parsed
+    "polyline" -> PolyLineTree parsed
+    "polygon" -> PolygonTree parsed
+    "circle"-> CircleTree parsed
+    "line"  -> LineTree parsed
+    "path" -> PathTree parsed
+    "meshgradient" ->
+      MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e
+    "use" -> UseTree parsed Nothing
+    _ -> None
+  where
+    parsed :: (XMLUpdatable a, WithDrawAttributes a) => a
+    parsed = xmlUnparseWithDrawAttr e
+
+unparseDocument :: FilePath -> X.Element -> Maybe Document
+unparseDocument rootLocation e@(nodeName -> "svg") = Just Document
+    { _viewBox =
+        attributeFinder "viewBox" e >>= parse viewBoxParser
+    , _elements = parsedElements
+    , _width = lengthFind "width"
+    , _height = lengthFind "height"
+    , _definitions = symbols named
+    , _description = ""
+    , _styleRules = cssStyle named
+    , _documentLocation = rootLocation
+    }
+  where
+    (parsedElements, named) =
+        runState (mapM unparse $ elChildren e) emptyState
+    lengthFind n =
+        attributeFinder n e >>= parse complexNumber
+unparseDocument _ _ = Nothing
+
+-- | Transform a SVG document to a XML node.
+xmlOfDocument :: Document -> X.Element
+xmlOfDocument doc =
+    X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ defsTag ++ children)
+  where
+    attr name = X.Attr (X.unqual name)
+    children = catMaybes [serializeTreeNode el | el <- _elements doc]
+
+    defsTag | null defs = []
+            | otherwise = [X.node (X.unqual "defs") defs]
+
+    defs = catMaybes [elementRender k e | (k, e) <- M.assocs $ _definitions doc]
+
+    elementRender k e = case e of
+        ElementGeometry t -> serialize t
+        ElementMarker m -> serialize m
+        ElementMask m -> serialize m
+        ElementClipPath c -> serialize c
+        ElementPattern p -> serialize p
+        ElementLinearGradient lg -> addId $ serializeTreeNode lg
+        ElementRadialGradient rg -> addId $ serializeTreeNode rg
+        ElementMeshGradient   mg -> addId $ serializeTreeNode mg
+      where
+        addId = fmap (X.add_attr $ attr "id" k)
+
+        serialize :: (WithDrawAttributes e, XMLUpdatable e) => e -> Maybe X.Element
+        serialize el = case el^.drawAttr.attrId of
+          Nothing -> addId $ serializeTreeNode el
+          Just _id ->
+            let newNode = el & drawAttr.attrId .~ Just k in
+            serializeTreeNode newNode
+
+    docViewBox = case _viewBox doc of
+        Nothing -> []
+        Just b -> [attr "viewBox" $ serializeViewBox b]
+
+    descTag = case _description doc of
+        "" -> []
+        txt -> [X.node (X.unqual "desc") txt]
+
+    styleTag = case _styleRules doc of
+        [] -> []
+        rules -> [X.node (X.unqual "style")
+                        ([attr "type" "text/css"], txt)]
+          where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules
+
+    attrs =
+        docViewBox ++
+        [attr "xmlns" "http://www.w3.org/2000/svg"
+        ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink"
+        ,attr "version" "1.1"] ++
+        catMaybes [attr "width" . serializeNumber <$> _width doc
+                  ,attr "height" . serializeNumber <$> _height doc
+                  ]
+

@@ -1,61 +1,61 @@-name:                svg-tree-version:             0.6-synopsis:            SVG file loader and serializer-description:-  svg-tree provides types representing a SVG document,-  and allows to load and save it.-  .-  The types definition are aimed at rendering,-  so they are rather comple. For simpler SVG document building,-  look after `lucid-svg`.-  .-  To render an svg document you can use the `rasterific-svg` package---license:             BSD3-author:              Vincent Berthoux-maintainer:          Vincent Berthoux--- copyright:-category:            Graphics, Svg-build-type:          Simple-cabal-version:       >=1.10--extra-source-files: changelog.md--Source-Repository head-    Type:      git-    Location:  git://github.com/Twinside/svg-tree.git--Source-Repository this-    Type:      git-    Location:  git://github.com/Twinside/svg-tree.git-    Tag:       v0.6--library-  hs-source-dirs: src-  Ghc-options: -O3 -Wall-  default-language: Haskell2010-  exposed-modules: Graphics.Svg-                 , Graphics.Svg.CssTypes-                 , Graphics.Svg.Types--  other-modules: Graphics.Svg.NamedColors-               , Graphics.Svg.XmlParser-               , Graphics.Svg.PathParser-               , Graphics.Svg.CssParser-               , Graphics.Svg.ColorParser--  build-depends: base >= 4.5 && < 5-               , JuicyPixels >= 3.2-               , attoparsec >= 0.12-               , scientific >= 0.3-               , containers >= 0.4-               , xml        >= 1.3-               , bytestring >= 0.10-               , linear     >= 1.20-               , vector     >= 0.10-               , text       >= 1.1-               , transformers >= 0.3 && < 0.6-               , mtl        >= 2.1 && < 2.3-               , lens       >= 4.6 && < 5-+name:                svg-tree
+version:             0.6.1
+synopsis:            SVG file loader and serializer
+description:
+  svg-tree provides types representing a SVG document,
+  and allows to load and save it.
+  .
+  The types definition are aimed at rendering,
+  so they are rather comple. For simpler SVG document building,
+  look after `lucid-svg`.
+  .
+  To render an svg document you can use the `rasterific-svg` package
+
+
+license:             BSD3
+author:              Vincent Berthoux
+maintainer:          Vincent Berthoux
+-- copyright:
+category:            Graphics, Svg
+build-type:          Simple
+cabal-version:       >=1.10
+
+extra-source-files: changelog.md
+
+Source-Repository head
+    Type:      git
+    Location:  git://github.com/Twinside/svg-tree.git
+
+Source-Repository this
+    Type:      git
+    Location:  git://github.com/Twinside/svg-tree.git
+    Tag:       v0.6.1
+
+library
+  hs-source-dirs: src
+  Ghc-options: -O3 -Wall
+  default-language: Haskell2010
+  exposed-modules: Graphics.Svg
+                 , Graphics.Svg.CssTypes
+                 , Graphics.Svg.Types
+
+  other-modules: Graphics.Svg.NamedColors
+               , Graphics.Svg.XmlParser
+               , Graphics.Svg.PathParser
+               , Graphics.Svg.CssParser
+               , Graphics.Svg.ColorParser
+
+  build-depends: base >= 4.5 && < 5
+               , JuicyPixels >= 3.2
+               , attoparsec >= 0.12
+               , scientific >= 0.3
+               , containers >= 0.4
+               , xml        >= 1.3
+               , bytestring >= 0.10
+               , linear     >= 1.20
+               , vector     >= 0.10
+               , text       >= 1.1
+               , transformers >= 0.3 && < 0.6
+               , mtl        >= 2.1 && < 2.3
+               , lens       >= 4.6 && < 5
+