svg-tree 0.5.1.2 → 0.6

raw patch · 9 files changed

+3987/−3787 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +64/−60
• src/Graphics/Svg.hs +112/−111
• src/Graphics/Svg/ColorParser.hs +111/−111
• src/Graphics/Svg/CssParser.hs +257/−257
• src/Graphics/Svg/CssTypes.hs +271/−271
• src/Graphics/Svg/PathParser.hs +260/−231
• src/Graphics/Svg/Types.hs +1624/−1521
• src/Graphics/Svg/XmlParser.hs +1227/−1164
• svg-tree.cabal +61/−61

@@ -1,60 +1,64 @@--*-change-log-*-
-
-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: 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,111 +1,112 @@-{-# LANGUAGE CPP #-}
--- | Module providing basic input/output for the SVG document,
--- for document building, please refer to Graphics.Svg.Types.
-module Graphics.Svg ( -- * Saving/Loading functions
-                      loadSvgFile
-                    , parseSvgFile
-                    , xmlOfDocument
-                    , saveXmlFile
-
-                      -- * Manipulation functions
-                    , cssApply
-                    , cssRulesOfText
-                    , applyCSSRules
-                    , resolveUses
-
-                      -- * Type definitions
-                    , module Graphics.Svg.Types
-                    ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<$>) )
-#endif
-
-import Data.List( foldl' )
-import qualified Data.ByteString as B
-import qualified Data.Map as M
-import qualified Data.Text as T
-import Text.XML.Light.Input( parseXMLDoc )
-import Text.XML.Light.Output( ppcTopElement, prettyConfigPP )
-import Control.Lens
-
-import Graphics.Svg.Types
-import Graphics.Svg.CssTypes
-import Graphics.Svg.CssParser( cssRulesOfText )
-import Graphics.Svg.XmlParser
-
-{-import Graphics.Svg.CssParser-}
-
--- | Try to load an svg file on disc and parse it as
--- a SVG Document.
-loadSvgFile :: FilePath -> IO (Maybe Document)
-loadSvgFile filename =
-  parseSvgFile filename <$> B.readFile filename
-
--- | Parse an in-memory SVG file
-parseSvgFile :: FilePath    -- ^ Source path/URL of the document, used
-                            -- to resolve relative links.
-             -> B.ByteString
-             -> Maybe Document
-parseSvgFile filename fileContent =
-  parseXMLDoc fileContent >>= unparseDocument filename
-
--- | Save a svg Document on a file on disk.
-saveXmlFile :: FilePath -> Document -> IO ()
-saveXmlFile filePath =
-    writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument
-
-cssDeclApplyer :: DrawAttributes -> CssDeclaration
-               -> DrawAttributes
-cssDeclApplyer value (CssDeclaration txt elems) =
-   case lookup txt cssUpdaters of
-     Nothing -> value
-     Just f -> f value elems
-  where
-    cssUpdaters = [(T.pack $ _attributeName n, u) |
-                            (n, u) <- drawAttributesList]
-
--- | Rewrite a SVG Tree using some CSS rules.
---
--- This action will propagate the definition of the
--- css directly in each matched element.
-cssApply :: [CssRule] -> Tree -> Tree
-cssApply rules = zipTree go where
-  go [] = None
-  go ([]:_) = None
-  go context@((t:_):_) = t & drawAttr .~ attr'
-   where
-     matchingDeclarations =
-         findMatchingDeclarations rules context
-     attr = view drawAttr t
-     attr' = foldl' cssDeclApplyer attr matchingDeclarations
-
--- | For every 'use' tag, try to resolve the geometry associated
--- with it and place it in the scene Tree. It is important to
--- resolve the 'use' tag before applying the CSS rules, as some
--- rules may apply some elements matching the children of "use".
-resolveUses :: Document -> Document
-resolveUses doc =
-  doc { _elements = mapTree fetchUses <$> _elements doc }
-  where
-    fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo
-    fetchUses a = a
-
-    search nfo = maybe Nothing geometryExtract found where
-      found = M.lookup (_useName nfo) $ _definitions doc
-
-    geometryExtract c = case c of
-      ElementLinearGradient _ -> Nothing
-      ElementRadialGradient _ -> Nothing
-      ElementMask _ -> Nothing
-      ElementClipPath _ -> Nothing
-      ElementGeometry t -> Just t
-      ElementPattern _ -> Nothing
-      ElementMarker _ -> Nothing
-
--- | Rewrite the document by applying the CSS rules embedded
--- inside it.
-applyCSSRules :: Document -> Document
-applyCSSRules doc = doc
-    { _elements = cssApply (_styleRules doc) <$> _elements doc }
-
+{-# LANGUAGE CPP #-}+-- | Module providing basic input/output for the SVG document,+-- for document building, please refer to Graphics.Svg.Types.+module Graphics.Svg ( -- * Saving/Loading functions+                      loadSvgFile+                    , parseSvgFile+                    , xmlOfDocument+                    , saveXmlFile++                      -- * Manipulation functions+                    , cssApply+                    , cssRulesOfText+                    , applyCSSRules+                    , resolveUses++                      -- * Type definitions+                    , module Graphics.Svg.Types+                    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>) )+#endif++import Data.List( foldl' )+import qualified Data.ByteString as B+import qualified Data.Map as M+import qualified Data.Text as T+import Text.XML.Light.Input( parseXMLDoc )+import Text.XML.Light.Output( ppcTopElement, prettyConfigPP )+import Control.Lens++import Graphics.Svg.Types+import Graphics.Svg.CssTypes+import Graphics.Svg.CssParser( cssRulesOfText )+import Graphics.Svg.XmlParser++{-import Graphics.Svg.CssParser-}++-- | Try to load an svg file on disc and parse it as+-- a SVG Document.+loadSvgFile :: FilePath -> IO (Maybe Document)+loadSvgFile filename =+  parseSvgFile filename <$> B.readFile filename++-- | Parse an in-memory SVG file+parseSvgFile :: FilePath    -- ^ Source path/URL of the document, used+                            -- to resolve relative links.+             -> B.ByteString+             -> Maybe Document+parseSvgFile filename fileContent =+  parseXMLDoc fileContent >>= unparseDocument filename++-- | Save a svg Document on a file on disk.+saveXmlFile :: FilePath -> Document -> IO ()+saveXmlFile filePath =+    writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument++cssDeclApplyer :: DrawAttributes -> CssDeclaration+               -> DrawAttributes+cssDeclApplyer value (CssDeclaration txt elems) =+   case lookup txt cssUpdaters of+     Nothing -> value+     Just f -> f value elems+  where+    cssUpdaters = [(T.pack $ _attributeName n, u) |+                            (n, u) <- drawAttributesList]++-- | Rewrite a SVG Tree using some CSS rules.+--+-- This action will propagate the definition of the+-- css directly in each matched element.+cssApply :: [CssRule] -> Tree -> Tree+cssApply rules = zipTree go where+  go [] = None+  go ([]:_) = None+  go context@((t:_):_) = t & drawAttr .~ attr'+   where+     matchingDeclarations =+         findMatchingDeclarations rules context+     attr = view drawAttr t+     attr' = foldl' cssDeclApplyer attr matchingDeclarations++-- | For every 'use' tag, try to resolve the geometry associated+-- with it and place it in the scene Tree. It is important to+-- resolve the 'use' tag before applying the CSS rules, as some+-- rules may apply some elements matching the children of "use".+resolveUses :: Document -> Document+resolveUses doc =+  doc { _elements = mapTree fetchUses <$> _elements doc }+  where+    fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo+    fetchUses a = a++    search nfo = maybe Nothing geometryExtract found where+      found = M.lookup (_useName nfo) $ _definitions doc++    geometryExtract c = case c of+      ElementLinearGradient _ -> Nothing+      ElementRadialGradient _ -> Nothing+      ElementMeshGradient _ -> Nothing+      ElementMask _ -> Nothing+      ElementClipPath _ -> Nothing+      ElementGeometry t -> Just t+      ElementPattern _ -> Nothing+      ElementMarker _ -> Nothing++-- | Rewrite the document by applying the CSS rules embedded+-- inside it.+applyCSSRules :: Document -> Document+applyCSSRules doc = doc+    { _elements = cssApply (_styleRules doc) <$> _elements doc }+

@@ -1,111 +1,111 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Graphics.Svg.ColorParser( colorParser
-                               , colorSerializer
-                               , textureParser
-                               , textureSerializer
-                               , urlRef
-                               ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$)  )
-#endif
-
-import Data.Bits( (.|.), unsafeShiftL )
-import Control.Applicative( (<|>) )
-import Data.Attoparsec.Text
-    ( Parser
-    , string
-    , skipSpace
-    , satisfy
-    , inClass
-    , takeWhile1
-    , option
-    , char
-    , digit
-    , letter
-    , many1
-    , scientific
-    )
-
-import Text.Printf( printf )
-import Data.Scientific( toRealFloat )
-import Codec.Picture( PixelRGBA8( .. ) )
-import Data.Word( Word8 )
-import Graphics.Svg.NamedColors
-import Graphics.Svg.Types
-import qualified Data.Map as M
-
-commaWsp :: Parser ()
-commaWsp = skipSpace *> option () (string "," *> return ())
-                     <* skipSpace
-
-
-num :: Parser Double
-num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)
-  where doubleNumber :: Parser Double
-        doubleNumber = toRealFloat <$> scientific
-
-        plusMinus = negate <$ string "-" <*> doubleNumber
-                 <|> string "+" *> doubleNumber
-                 <|> doubleNumber
-
-colorSerializer :: PixelRGBA8 -> String
-colorSerializer (PixelRGBA8 r g b _) = printf "#%02X%02X%02X" r g b
-
-colorParser :: Parser PixelRGBA8
-colorParser = rgbColor
-           <|> (string "#" *> (color <|> colorReduced))
-           <|> namedColor
-  where
-    charRange c1 c2 =
-        (\c -> fromIntegral $ fromEnum c - fromEnum c1) <$> satisfy (\v -> c1 <= v && v <= c2)
-    black = PixelRGBA8 0 0 0 255
-
-    hexChar :: Parser Word8
-    hexChar = charRange '0' '9'
-           <|> ((+ 10) <$> charRange 'a' 'f')
-           <|> ((+ 10) <$> charRange 'A' 'F')
-
-    namedColor = do
-      str <- takeWhile1 (inClass "a-z")
-      return $ M.findWithDefault black str svgNamedColors
-
-    percentToWord v = floor $ v * (255 / 100)
-
-    numPercent = ((percentToWord <$> num) <* string "%")
-              <|> (floor <$> num)
-
-    hexByte = (\h1 h2 -> h1 `unsafeShiftL` 4 .|. h2)
-           <$> hexChar <*> hexChar
-
-    color = (\r g b -> PixelRGBA8 r g b 255)
-         <$> hexByte <*> hexByte <*> hexByte
-    rgbColor = (\r g b -> PixelRGBA8 r g b 255)
-            <$> (string "rgb(" *> numPercent)
-            <*> (commaWsp *> numPercent)
-            <*> (commaWsp *> numPercent <* skipSpace <* string ")")
-
-    colorReduced =
-        (\r g b -> PixelRGBA8 (r * 17) (g * 17) (b * 17) 255)
-        <$> hexChar <*> hexChar <*> hexChar
-
-
-textureSerializer :: Texture -> String
-textureSerializer (ColorRef px) = colorSerializer px
-textureSerializer (TextureRef str) = printf "url(#%s)" str
-textureSerializer FillNone = "none"
-
-urlRef :: Parser String
-urlRef = string "url(" *> skipSpace *>
-       char '#' *> many1 (letter <|> digit)
-       <* skipSpace <* char ')' <* skipSpace
-
-
-textureParser :: Parser Texture
-textureParser =
-  none <|> (TextureRef <$> urlRef)
-       <|> (ColorRef <$> colorParser)
-  where
-    none = FillNone <$ string "none"
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Graphics.Svg.ColorParser( colorParser+                               , colorSerializer+                               , textureParser+                               , textureSerializer+                               , urlRef+                               ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$)  )+#endif++import Data.Bits( (.|.), unsafeShiftL )+import Control.Applicative( (<|>) )+import Data.Attoparsec.Text+    ( Parser+    , string+    , skipSpace+    , satisfy+    , inClass+    , takeWhile1+    , option+    , char+    , digit+    , letter+    , many1+    , scientific+    )++import Text.Printf( printf )+import Data.Scientific( toRealFloat )+import Codec.Picture( PixelRGBA8( .. ) )+import Data.Word( Word8 )+import Graphics.Svg.NamedColors+import Graphics.Svg.Types+import qualified Data.Map as M++commaWsp :: Parser ()+commaWsp = skipSpace *> option () (string "," *> return ())+                     <* skipSpace+++num :: Parser Double+num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)+  where doubleNumber :: Parser Double+        doubleNumber = toRealFloat <$> scientific++        plusMinus = negate <$ string "-" <*> doubleNumber+                 <|> string "+" *> doubleNumber+                 <|> doubleNumber++colorSerializer :: PixelRGBA8 -> String+colorSerializer (PixelRGBA8 r g b _) = printf "#%02X%02X%02X" r g b++colorParser :: Parser PixelRGBA8+colorParser = rgbColor+           <|> (string "#" *> (color <|> colorReduced))+           <|> namedColor+  where+    charRange c1 c2 =+        (\c -> fromIntegral $ fromEnum c - fromEnum c1) <$> satisfy (\v -> c1 <= v && v <= c2)+    black = PixelRGBA8 0 0 0 255++    hexChar :: Parser Word8+    hexChar = charRange '0' '9'+           <|> ((+ 10) <$> charRange 'a' 'f')+           <|> ((+ 10) <$> charRange 'A' 'F')++    namedColor = do+      str <- takeWhile1 (inClass "a-z")+      return $ M.findWithDefault black str svgNamedColors++    percentToWord v = floor $ v * (255 / 100)++    numPercent = ((percentToWord <$> num) <* string "%")+              <|> (floor <$> num)++    hexByte = (\h1 h2 -> h1 `unsafeShiftL` 4 .|. h2)+           <$> hexChar <*> hexChar++    color = (\r g b -> PixelRGBA8 r g b 255)+         <$> hexByte <*> hexByte <*> hexByte+    rgbColor = (\r g b -> PixelRGBA8 r g b 255)+            <$> (string "rgb(" *> numPercent)+            <*> (commaWsp *> numPercent)+            <*> (commaWsp *> numPercent <* skipSpace <* string ")")++    colorReduced =+        (\r g b -> PixelRGBA8 (r * 17) (g * 17) (b * 17) 255)+        <$> hexChar <*> hexChar <*> hexChar+++textureSerializer :: Texture -> String+textureSerializer (ColorRef px) = colorSerializer px+textureSerializer (TextureRef str) = printf "url(#%s)" str+textureSerializer FillNone = "none"++urlRef :: Parser String+urlRef = string "url(" *> skipSpace *>+       char '#' *> many1 (letter <|> digit)+       <* skipSpace <* char ')' <* skipSpace+++textureParser :: Parser Texture+textureParser =+  none <|> (TextureRef <$> urlRef)+       <|> (ColorRef <$> colorParser)+  where+    none = FillNone <$ string "none"+

@@ -1,257 +1,257 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards #-}
-module Graphics.Svg.CssParser
-    ( CssElement( .. )
-    , complexNumber
-    , declaration
-    , ruleSet
-    , styleString
-    , dashArray
-    , numberList
-    , num
-    , cssRulesOfText
-    )
-    where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<*>), (<*), (*>)
-                          , (<$>), (<$)
-                          , pure
-                          )
-#endif
-
-import Control.Applicative( (<|>)
-                          , many
-                          )
-import Data.Attoparsec.Text
-    ( Parser
-    , double
-    , string
-    , skipSpace
-    , letter
-    , char
-    , digit
-    {-, skip-}
-    , sepBy1
-    , (<?>)
-    , skipMany
-    , notChar
-    , parseOnly
-    )
-import qualified Data.Attoparsec.Text as AT
-
-import Data.Attoparsec.Combinator
-    ( option
-    , sepBy
-    {-, sepBy1-}
-    , many1
-    )
-
-import Codec.Picture( PixelRGBA8( .. ) )
-import Graphics.Svg.Types
-import Graphics.Svg.NamedColors( svgNamedColors )
-import Graphics.Svg.ColorParser( colorParser )
-import Graphics.Svg.CssTypes
-import qualified Data.Text as T
-import qualified Data.Map as M
-{-import Graphics.Rasterific.Linear( V2( V2 ) )-}
-{-import Graphics.Rasterific.Transformations-}
-
-num :: Parser Double
-num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)
-  where doubleNumber = char '.' *> (scale <$> double)
-                    <|> double
-
-        scalingCoeff n = 10 ^ digitCount
-          where digitCount :: Int
-                digitCount = ceiling . logBase 10 $ abs n
-
-        scale n = n / scalingCoeff n
-
-        plusMinus = negate <$ string "-" <*> doubleNumber
-                 <|> string "+" *> doubleNumber
-                 <|> doubleNumber
-
-
-ident :: Parser T.Text
-ident =
-  (\f c -> f . T.cons c . T.pack)
-        <$> trailingSub
-        <*> nmstart <*> nmchar
-  where
-    trailingSub = option id $ T.cons '-' <$ char '-'
-    underscore = char '_'
-    nmstart = letter <|> underscore
-    nmchar = many (letter <|> digit <|> underscore <|> char '-')
-
-str :: Parser T.Text
-str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace
-   <?> "str"
-
-between :: Char -> Char -> Parser a -> Parser a
-between o e p =
-  (skipSpace *>
-      char o *> skipSpace *> p
-           <* skipSpace <* char e <* skipSpace)
-           <?> ("between " ++ [o, e])
-
-bracket :: Parser a -> Parser a
-bracket = between '[' ']'
-
-
-comment :: Parser ()
-comment = string "/*" *> toStar *> skipSpace
-  where
-    toStar = skipMany (notChar '*') *> char '*' *> testEnd
-    testEnd = (() <$ char '/') <|> toStar
-
-cleanSpace :: Parser ()
-cleanSpace = skipSpace <* many comment
-
--- | combinator: '+' S* | '>' S*
-combinator :: Parser CssSelector
-combinator = parse <* cleanSpace where
-  parse = Nearby <$ char '+'
-       <|> DirectChildren <$ char '>'
-       <?> "combinator"
-
--- unary_operator : '-' | '+' ;
-
-commaWsp :: Parser Char
-commaWsp = skipSpace *> option ',' (char ',') <* skipSpace
-
-ruleSet :: Parser CssRule
-ruleSet = cleanSpace *> rule where
-  rule = CssRule
-      <$> selector `sepBy1` commaWsp
-      <*> (between '{' '}' styleString)
-      <?> "cssrule"
-
-styleString :: Parser [CssDeclaration]
-styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp
-           <?> "styleString"
-  where semiWsp = skipSpace *> char ';' <* skipSpace
-        mayWsp = option ';' semiWsp
-
-selector :: Parser [CssSelector]
-selector = (:)
-        <$> (AllOf <$> simpleSelector <* skipSpace <?> "firstpart:(")
-        <*> ((next <|> return []) <?> "secondpart")
-        <?> "selector"
-  where
-    combOpt :: Parser ([CssSelector] -> [CssSelector])
-
-    combOpt = cleanSpace *> option id ((:) <$> combinator)
-    next :: Parser [CssSelector]
-    next = id <$> combOpt <*> selector
-
-simpleSelector :: Parser [CssDescriptor]
-simpleSelector = (:) <$> elementName <*> many whole
-              <|> (many1 whole <?> "inmany")
-              <?> "simple selector"
- where
-  whole = pseudo <|> hash <|> classParser <|> attrib
-       <?> "whole"
-  pseudo = char ':' *> (OfPseudoClass <$> ident)
-        <?> "pseudo"
-  hash = char '#' *> (OfId <$> ident)
-      <?> "hash"
-  classParser = char '.' *> (OfClass <$> ident)
-              <?> "classParser"
-
-  elementName = el <* skipSpace <?> "elementName"
-    where el = (OfName <$> ident)
-            <|> AnyElem <$ char '*'
-
-  attrib = bracket
-    (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str))
-           <?> "attrib")
-
-declaration :: Parser CssDeclaration
-declaration =
-  CssDeclaration <$> property
-                 <*> (char ':'
-                      *> cleanSpace
-                      *> many1 expr
-                      <* prio
-                      )
-                 <?> "declaration"
-  where
-    property = (ident <* cleanSpace) <?> "property"
-    prio = option "" $ string "!important"
-
-operator :: Parser CssElement
-operator = skipSpace *> op <* skipSpace
-  where
-    op = CssOpSlash <$ char '/'
-      <|> CssOpComa <$ char ','
-      <?> "operator"
-
-expr :: Parser [CssElement]
-expr = ((:) <$> term <*> (concat <$> many termOp))
-    <?> "expr"
-  where
-    op = option (:[]) $ (\a b -> [a, b]) <$> operator
-    termOp = ($) <$> op <*> term
-
-dashArray :: Parser [Number]
-dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp)
-
-numberList :: Parser [Double]
-numberList = skipSpace *> (num `sepBy1` commaWsp)
-
-complexNumber :: Parser Number
-complexNumber = do
-    n <- num
-    (Percent (n / 100) <$ char '%')
-        <|> (Em n <$ string "em")
-        <|> (Mm n <$ string "mm")
-        <|> (Cm n <$ string "cm")
-        <|> (Point n <$ string "pt")
-        <|> (Pc n <$ string "pc")
-        <|> (Px n <$ string "px")
-        <|> (Inches n <$ string "in")
-        <|> pure (Num n)
-
-term :: Parser CssElement
-term = checkRgb <$> function
-    <|> (CssNumber <$> complexNumber)
-    <|> (CssString <$> str)
-    <|> (checkNamedColor <$> ident)
-    <|> (CssColor <$> colorParser)
-  where
-    comma = skipSpace *> char ',' <* skipSpace
-    checkNamedColor n
-        | Just c <- M.lookup n svgNamedColors = CssColor c
-        | otherwise = CssIdent n
-
-    ref = char '#' *> ident
-
-    checkRgb (CssFunction "rgb"
-                [CssNumber r, CssNumber g, CssNumber b]) =
-        CssColor $ PixelRGBA8 (to r) (to g) (to b) 255
-       where clamp = max 0 . min 255
-             to (Num n) = floor $ clamp n
-             to (Px n) = floor $ clamp n
-             to (Percent p) = floor . clamp $ p * 255
-             to (Em c) = floor $ clamp c
-             to (Pc n) = floor $ clamp n
-             to (Mm n) = floor $ clamp n
-             to (Cm n) = floor $ clamp n
-             to (Point n) = floor $ clamp n
-             to (Inches n) = floor $ clamp n
-
-    checkRgb a = a
-    functionParam = (CssReference <$> ref) <|> term
-
-    function = CssFunction
-       <$> ident <* char '('
-       <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace
-
--- | Parse CSS text into rules.
-cssRulesOfText :: T.Text -> [CssRule]
-cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of
-    Left _ -> []
-    Right rules -> rules
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+module Graphics.Svg.CssParser+    ( CssElement( .. )+    , complexNumber+    , declaration+    , ruleSet+    , styleString+    , dashArray+    , numberList+    , num+    , cssRulesOfText+    )+    where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<*), (*>)+                          , (<$>), (<$)+                          , pure+                          )+#endif++import Control.Applicative( (<|>)+                          , many+                          )+import Data.Attoparsec.Text+    ( Parser+    , double+    , string+    , skipSpace+    , letter+    , char+    , digit+    {-, skip-}+    , sepBy1+    , (<?>)+    , skipMany+    , notChar+    , parseOnly+    )+import qualified Data.Attoparsec.Text as AT++import Data.Attoparsec.Combinator+    ( option+    , sepBy+    {-, sepBy1-}+    , many1+    )++import Codec.Picture( PixelRGBA8( .. ) )+import Graphics.Svg.Types+import Graphics.Svg.NamedColors( svgNamedColors )+import Graphics.Svg.ColorParser( colorParser )+import Graphics.Svg.CssTypes+import qualified Data.Text as T+import qualified Data.Map as M+{-import Graphics.Rasterific.Linear( V2( V2 ) )-}+{-import Graphics.Rasterific.Transformations-}++num :: Parser Double+num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)+  where doubleNumber = char '.' *> (scale <$> double)+                    <|> double++        scalingCoeff n = 10 ^ digitCount+          where digitCount :: Int+                digitCount = ceiling . logBase 10 $ abs n++        scale n = n / scalingCoeff n++        plusMinus = negate <$ string "-" <*> doubleNumber+                 <|> string "+" *> doubleNumber+                 <|> doubleNumber+++ident :: Parser T.Text+ident =+  (\f c -> f . T.cons c . T.pack)+        <$> trailingSub+        <*> nmstart <*> nmchar+  where+    trailingSub = option id $ T.cons '-' <$ char '-'+    underscore = char '_'+    nmstart = letter <|> underscore+    nmchar = many (letter <|> digit <|> underscore <|> char '-')++str :: Parser T.Text+str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace+   <?> "str"++between :: Char -> Char -> Parser a -> Parser a+between o e p =+  (skipSpace *>+      char o *> skipSpace *> p+           <* skipSpace <* char e <* skipSpace)+           <?> ("between " ++ [o, e])++bracket :: Parser a -> Parser a+bracket = between '[' ']'+++comment :: Parser ()+comment = string "/*" *> toStar *> skipSpace+  where+    toStar = skipMany (notChar '*') *> char '*' *> testEnd+    testEnd = (() <$ char '/') <|> toStar++cleanSpace :: Parser ()+cleanSpace = skipSpace <* many comment++-- | combinator: '+' S* | '>' S*+combinator :: Parser CssSelector+combinator = parse <* cleanSpace where+  parse = Nearby <$ char '+'+       <|> DirectChildren <$ char '>'+       <?> "combinator"++-- unary_operator : '-' | '+' ;++commaWsp :: Parser Char+commaWsp = skipSpace *> option ',' (char ',') <* skipSpace++ruleSet :: Parser CssRule+ruleSet = cleanSpace *> rule where+  rule = CssRule+      <$> selector `sepBy1` commaWsp+      <*> (between '{' '}' styleString)+      <?> "cssrule"++styleString :: Parser [CssDeclaration]+styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp+           <?> "styleString"+  where semiWsp = skipSpace *> char ';' <* skipSpace+        mayWsp = option ';' semiWsp++selector :: Parser [CssSelector]+selector = (:)+        <$> (AllOf <$> simpleSelector <* skipSpace <?> "firstpart:(")+        <*> ((next <|> return []) <?> "secondpart")+        <?> "selector"+  where+    combOpt :: Parser ([CssSelector] -> [CssSelector])++    combOpt = cleanSpace *> option id ((:) <$> combinator)+    next :: Parser [CssSelector]+    next = id <$> combOpt <*> selector++simpleSelector :: Parser [CssDescriptor]+simpleSelector = (:) <$> elementName <*> many whole+              <|> (many1 whole <?> "inmany")+              <?> "simple selector"+ where+  whole = pseudo <|> hash <|> classParser <|> attrib+       <?> "whole"+  pseudo = char ':' *> (OfPseudoClass <$> ident)+        <?> "pseudo"+  hash = char '#' *> (OfId <$> ident)+      <?> "hash"+  classParser = char '.' *> (OfClass <$> ident)+              <?> "classParser"++  elementName = el <* skipSpace <?> "elementName"+    where el = (OfName <$> ident)+            <|> AnyElem <$ char '*'++  attrib = bracket+    (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str))+           <?> "attrib")++declaration :: Parser CssDeclaration+declaration =+  CssDeclaration <$> property+                 <*> (char ':'+                      *> cleanSpace+                      *> many1 expr+                      <* prio+                      )+                 <?> "declaration"+  where+    property = (ident <* cleanSpace) <?> "property"+    prio = option "" $ string "!important"++operator :: Parser CssElement+operator = skipSpace *> op <* skipSpace+  where+    op = CssOpSlash <$ char '/'+      <|> CssOpComa <$ char ','+      <?> "operator"++expr :: Parser [CssElement]+expr = ((:) <$> term <*> (concat <$> many termOp))+    <?> "expr"+  where+    op = option (:[]) $ (\a b -> [a, b]) <$> operator+    termOp = ($) <$> op <*> term++dashArray :: Parser [Number]+dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp)++numberList :: Parser [Double]+numberList = skipSpace *> (num `sepBy1` commaWsp)++complexNumber :: Parser Number+complexNumber = do+    n <- num+    (Percent (n / 100) <$ char '%')+        <|> (Em n <$ string "em")+        <|> (Mm n <$ string "mm")+        <|> (Cm n <$ string "cm")+        <|> (Point n <$ string "pt")+        <|> (Pc n <$ string "pc")+        <|> (Px n <$ string "px")+        <|> (Inches n <$ string "in")+        <|> pure (Num n)++term :: Parser CssElement+term = checkRgb <$> function+    <|> (CssNumber <$> complexNumber)+    <|> (CssString <$> str)+    <|> (checkNamedColor <$> ident)+    <|> (CssColor <$> colorParser)+  where+    comma = skipSpace *> char ',' <* skipSpace+    checkNamedColor n+        | Just c <- M.lookup n svgNamedColors = CssColor c+        | otherwise = CssIdent n++    ref = char '#' *> ident++    checkRgb (CssFunction "rgb"+                [CssNumber r, CssNumber g, CssNumber b]) =+        CssColor $ PixelRGBA8 (to r) (to g) (to b) 255+       where clamp = max 0 . min 255+             to (Num n) = floor $ clamp n+             to (Px n) = floor $ clamp n+             to (Percent p) = floor . clamp $ p * 255+             to (Em c) = floor $ clamp c+             to (Pc n) = floor $ clamp n+             to (Mm n) = floor $ clamp n+             to (Cm n) = floor $ clamp n+             to (Point n) = floor $ clamp n+             to (Inches n) = floor $ clamp n++    checkRgb a = a+    functionParam = (CssReference <$> ref) <|> term++    function = CssFunction+       <$> ident <* char '('+       <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace++-- | Parse CSS text into rules.+cssRulesOfText :: T.Text -> [CssRule]+cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of+    Left _ -> []+    Right rules -> rules+

@@ -1,271 +1,271 @@-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
--- | Define the types used to describes CSS elements
-module Graphics.Svg.CssTypes
-    ( CssSelector( .. )
-    , CssSelectorRule
-    , CssRule( .. )
-    , CssDescriptor( .. )
-    , CssDeclaration( .. )
-    , CssElement( .. )
-
-    , CssMatcheable( .. )
-    , CssContext
-    , Dpi
-    , Number( .. )
-    , serializeNumber
-    , findMatchingDeclarations
-    , toUserUnit
-    , mapNumber
-    , tserialize
-    ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Data.Monoid( mconcat )
-#endif
-
-import Data.Monoid( (<>) )
-import Data.List( intersperse )
-import qualified Data.Text as T
-import qualified Data.Text.Lazy.Builder as TB
-import Text.Printf
-
-import Codec.Picture( PixelRGBA8( .. ) )
-
--- | Alias describing a "dot per inch" information
--- used for size calculation (see toUserUnit).
-type Dpi = Int
-
--- | Helper typeclass for serialization to Text.
-class TextBuildable a where
-    -- | Serialize an element to a text builder.
-    tserialize :: a -> TB.Builder
-
--- | Describe an element of a CSS selector. Multiple
--- elements can be combined in a CssSelector type.
-data CssDescriptor
-  = OfClass T.Text    -- ^ .IDENT
-  | OfName  T.Text    -- ^ IDENT
-  | OfId    T.Text    -- ^ #IDENT
-  | OfPseudoClass T.Text     -- ^ `:IDENT` (ignore function syntax)
-  | AnyElem                  -- ^ '*'
-  | WithAttrib T.Text T.Text -- ^ ``
-  deriving (Eq, Show)
-
-instance TextBuildable CssDescriptor where
-  tserialize d = case d of
-      OfClass c -> si '.' <> ft c
-      OfName  n -> ft n
-      OfId    i -> si '#' <> ft i
-      OfPseudoClass c -> si '#' <> ft c
-      AnyElem -> si '*'
-      WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']']
-     where
-      ft = TB.fromText
-      si = TB.singleton
-
--- | Define complex selector.
-data CssSelector
-  = Nearby          -- ^ Correspond to the `+` CSS selector.
-  | DirectChildren  -- ^ Correspond to the `>` CSS selectro.
-  | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements
-                          -- of the list must be matched.
-  deriving (Eq, Show)
-
-instance TextBuildable CssSelector where
-  tserialize s = case s of
-      Nearby -> si '+'
-      DirectChildren -> si '>'
-      AllOf lst -> mconcat $ map tserialize lst
-    where
-      si = TB.singleton
-
--- | A CssSelectorRule is a list of all the elements
--- that must be meet in a depth first search fashion.
-type CssSelectorRule = [CssSelector]
-
--- | Represent a CSS selector and the different declarations
--- to apply to the matched elemens.
-data CssRule = CssRule
-    { -- | At the first level represent a list of elements
-      -- to be matched. If any match is made, you can apply
-      -- the declarations. At the second level
-      cssRuleSelector :: ![CssSelectorRule]
-      -- | Declarations to apply to the matched element.
-    , cssDeclarations :: ![CssDeclaration]
-    }
-    deriving (Eq, Show)
-
-instance TextBuildable CssRule where
-  tserialize (CssRule selectors decl) =
-      mconcat tselectors
-                 <> ft " {\n"
-                 <> mconcat (fmap tserializeDecl decl)
-                 <> ft "}\n"
-     where
-      ft = TB.fromText
-      tserializeDecl d = ft "  " <> tserialize d <> ft ";\n"
-      tselector =
-          mconcat . intersperse (ft " ") . fmap tserialize
-      tselectors = 
-          intersperse (ft ",\n") $ fmap tselector selectors
-
--- | Interface for elements to be matched against
--- some CssRule.
-class CssMatcheable a where
-  -- | For an element, tell its optional ID attribute.
-  cssIdOf     :: a -> Maybe T.Text
-  -- | For an element, return all of it's class attributes.
-  cssClassOf  :: a -> [T.Text]
-  -- | Return the name of the tagname of the element
-  cssNameOf   :: a -> T.Text
-  -- | Return a value of a given attribute if present
-  cssAttribOf :: a -> T.Text -> Maybe T.Text
-
--- | Represent a zipper in depth at the first list
--- level, and the previous nodes at in the second
--- list level.
-type CssContext a = [[a]]
-
-isDescribedBy :: CssMatcheable a
-              => a -> [CssDescriptor] -> Bool
-isDescribedBy e = all tryMatch
-  where
-    tryMatch (OfClass t) = t `elem` cssClassOf e
-    tryMatch (OfId    i) = cssIdOf e == Just i
-    tryMatch (OfName  n) = cssNameOf e == n
-    tryMatch (OfPseudoClass _) = False
-    tryMatch (WithAttrib a v) = cssAttribOf e a == Just v
-    tryMatch AnyElem = True
-
-isMatching :: CssMatcheable a
-           => CssContext a -> [CssSelector] -> Bool
-isMatching = go where
-  go  _ [] = True
-  go []  _ = False
-  go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest
-  go ((e:_):upper) (DirectChildren:AllOf descr:rest)
-    | isDescribedBy e descr = go upper rest
-  go _ (DirectChildren:_) = False
-  go ((e:_):upper) selectors@(AllOf descr : rest)
-    | isDescribedBy e descr = go upper rest
-    | otherwise = go upper selectors
-  go (_:upper) selector = go upper selector
-
--- | Given CSS rules, find all the declaration to apply to the
--- element in a given context.
-findMatchingDeclarations :: CssMatcheable a
-                         => [CssRule] -> CssContext a -> [CssDeclaration]
-findMatchingDeclarations rules context =
-    concat [cssDeclarations rule
-                    | rule <- rules
-                    , selector <- cssRuleSelector rule
-                    , isMatching context $ reverse selector ]
-
--- | Represent the content to apply to some
--- CSS matched rules.
-data CssDeclaration = CssDeclaration
-    { -- | Property name to change (like font-family or color).
-      _cssDeclarationProperty :: T.Text
-      -- | List of values
-    , _cssDecarationlValues   :: [[CssElement]]
-    }
-    deriving (Eq, Show)
-
-instance TextBuildable CssDeclaration where
-  tserialize (CssDeclaration n elems) =
-      mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems
-     where
-      finalElems = map tserialize (concat elems)
-      ft = TB.fromText
-      si = TB.singleton
-
-
--- | Encode complex number possibly dependant to the current
--- render size.
-data Number
-  = Num Double       -- ^ Simple coordinate in current user coordinate.
-  | Px Double        -- ^ With suffix "px"
-  | Em Double        -- ^ Number relative to the current font size.
-  | Percent Double   -- ^ Number relative to the current viewport size.
-  | Pc Double
-  | Mm Double        -- ^ Number in millimeters, relative to DPI.
-  | Cm Double        -- ^ Number in centimeters, relative to DPI.
-  | Point Double     -- ^ Number in points, relative to DPI.
-  | Inches Double    -- ^ Number in inches, relative to DPI.
-  deriving (Eq, Show)
-
--- | Helper function to modify inner value of a number
-mapNumber :: (Double -> Double) -> Number -> Number
-mapNumber f nu = case nu of
-  Num n -> Num $ f n
-  Px n -> Px $ f n
-  Em n -> Em $ f n
-  Percent n -> Percent $ f n
-  Pc n -> Pc $ f n
-  Mm n -> Mm $ f n
-  Cm n -> Cm $ f n
-  Point n -> Point $ f n
-  Inches n -> Inches $ f n
-
--- | Encode the number to string which can be used in a
--- CSS or a svg attributes.
-serializeNumber :: Number -> String
-serializeNumber n = case n of
-    Num c -> printf "%g" c
-    Px c -> printf "%gpx" c
-    Em cc -> printf "%gem" cc
-    Percent p -> printf "%d%%" (floor $ 100 * p :: Int)
-    Pc p -> printf "%gpc" p
-    Mm m -> printf "%gmm" m
-    Cm c -> printf "%gcm" c
-    Point p -> printf "%gpt" p
-    Inches i -> printf "%gin" i
-
-instance TextBuildable Number where
-   tserialize = TB.fromText . T.pack . serializeNumber
-
--- | Value of a CSS property.
-data CssElement
-    = CssIdent     !T.Text
-    | CssString    !T.Text
-    | CssReference !T.Text
-    | CssNumber    !Number
-    | CssColor     !PixelRGBA8
-    | CssFunction  !T.Text ![CssElement]
-    | CssOpComa
-    | CssOpSlash
-    deriving (Eq, Show)
-
-instance TextBuildable CssElement where
-  tserialize e = case e of
-    CssIdent    n -> ft n
-    CssString   s -> si '"' <> ft s <> si '"'
-    CssReference r -> si '#' <> ft r
-    CssNumber   n -> tserialize n
-    CssColor  (PixelRGBA8 r g b _) ->
-      ft . T.pack $ printf  "#%02X%02X%02X" r g b
-    CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')']
-        where args = intersperse (ft ", ") (map tserialize els)
-    CssOpComa -> si ','
-    CssOpSlash -> si '/'
-    where
-      ft = TB.fromText
-      si = TB.singleton
-
--- | This function replace all device dependant units to user
--- units given it's DPI configuration.
--- Preserve percentage and "em" notation.
-toUserUnit :: Dpi -> Number -> Number
-toUserUnit dpi = go where
-  go nu = case nu of
-    Num _ -> nu
-    Px p -> go $ Num p
-    Em _ -> nu
-    Percent _ -> nu
-    Pc n -> go . Inches $ (12 * n) / 72
-    Inches n -> Num $ n * fromIntegral dpi
-    Mm n -> go . Inches $ n / 25.4
-    Cm n -> go . Inches $ n / 2.54
-    Point n -> go . Inches $ n / 72
-
+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+-- | Define the types used to describes CSS elements+module Graphics.Svg.CssTypes+    ( CssSelector( .. )+    , CssSelectorRule+    , CssRule( .. )+    , CssDescriptor( .. )+    , CssDeclaration( .. )+    , CssElement( .. )++    , CssMatcheable( .. )+    , CssContext+    , Dpi+    , Number( .. )+    , serializeNumber+    , findMatchingDeclarations+    , toUserUnit+    , mapNumber+    , tserialize+    ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mconcat )+#endif++import Data.Monoid( (<>) )+import Data.List( intersperse )+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TB+import Text.Printf++import Codec.Picture( PixelRGBA8( .. ) )++-- | Alias describing a "dot per inch" information+-- used for size calculation (see toUserUnit).+type Dpi = Int++-- | Helper typeclass for serialization to Text.+class TextBuildable a where+    -- | Serialize an element to a text builder.+    tserialize :: a -> TB.Builder++-- | Describe an element of a CSS selector. Multiple+-- elements can be combined in a CssSelector type.+data CssDescriptor+  = OfClass T.Text    -- ^ .IDENT+  | OfName  T.Text    -- ^ IDENT+  | OfId    T.Text    -- ^ #IDENT+  | OfPseudoClass T.Text     -- ^ `:IDENT` (ignore function syntax)+  | AnyElem                  -- ^ '*'+  | WithAttrib T.Text T.Text -- ^ ``+  deriving (Eq, Show)++instance TextBuildable CssDescriptor where+  tserialize d = case d of+      OfClass c -> si '.' <> ft c+      OfName  n -> ft n+      OfId    i -> si '#' <> ft i+      OfPseudoClass c -> si '#' <> ft c+      AnyElem -> si '*'+      WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']']+     where+      ft = TB.fromText+      si = TB.singleton++-- | Define complex selector.+data CssSelector+  = Nearby          -- ^ Correspond to the `+` CSS selector.+  | DirectChildren  -- ^ Correspond to the `>` CSS selectro.+  | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements+                          -- of the list must be matched.+  deriving (Eq, Show)++instance TextBuildable CssSelector where+  tserialize s = case s of+      Nearby -> si '+'+      DirectChildren -> si '>'+      AllOf lst -> mconcat $ map tserialize lst+    where+      si = TB.singleton++-- | A CssSelectorRule is a list of all the elements+-- that must be meet in a depth first search fashion.+type CssSelectorRule = [CssSelector]++-- | Represent a CSS selector and the different declarations+-- to apply to the matched elemens.+data CssRule = CssRule+    { -- | At the first level represent a list of elements+      -- to be matched. If any match is made, you can apply+      -- the declarations. At the second level+      cssRuleSelector :: ![CssSelectorRule]+      -- | Declarations to apply to the matched element.+    , cssDeclarations :: ![CssDeclaration]+    }+    deriving (Eq, Show)++instance TextBuildable CssRule where+  tserialize (CssRule selectors decl) =+      mconcat tselectors+                 <> ft " {\n"+                 <> mconcat (fmap tserializeDecl decl)+                 <> ft "}\n"+     where+      ft = TB.fromText+      tserializeDecl d = ft "  " <> tserialize d <> ft ";\n"+      tselector =+          mconcat . intersperse (ft " ") . fmap tserialize+      tselectors = +          intersperse (ft ",\n") $ fmap tselector selectors++-- | Interface for elements to be matched against+-- some CssRule.+class CssMatcheable a where+  -- | For an element, tell its optional ID attribute.+  cssIdOf     :: a -> Maybe T.Text+  -- | For an element, return all of it's class attributes.+  cssClassOf  :: a -> [T.Text]+  -- | Return the name of the tagname of the element+  cssNameOf   :: a -> T.Text+  -- | Return a value of a given attribute if present+  cssAttribOf :: a -> T.Text -> Maybe T.Text++-- | Represent a zipper in depth at the first list+-- level, and the previous nodes at in the second+-- list level.+type CssContext a = [[a]]++isDescribedBy :: CssMatcheable a+              => a -> [CssDescriptor] -> Bool+isDescribedBy e = all tryMatch+  where+    tryMatch (OfClass t) = t `elem` cssClassOf e+    tryMatch (OfId    i) = cssIdOf e == Just i+    tryMatch (OfName  n) = cssNameOf e == n+    tryMatch (OfPseudoClass _) = False+    tryMatch (WithAttrib a v) = cssAttribOf e a == Just v+    tryMatch AnyElem = True++isMatching :: CssMatcheable a+           => CssContext a -> [CssSelector] -> Bool+isMatching = go where+  go  _ [] = True+  go []  _ = False+  go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest+  go ((e:_):upper) (DirectChildren:AllOf descr:rest)+    | isDescribedBy e descr = go upper rest+  go _ (DirectChildren:_) = False+  go ((e:_):upper) selectors@(AllOf descr : rest)+    | isDescribedBy e descr = go upper rest+    | otherwise = go upper selectors+  go (_:upper) selector = go upper selector++-- | Given CSS rules, find all the declaration to apply to the+-- element in a given context.+findMatchingDeclarations :: CssMatcheable a+                         => [CssRule] -> CssContext a -> [CssDeclaration]+findMatchingDeclarations rules context =+    concat [cssDeclarations rule+                    | rule <- rules+                    , selector <- cssRuleSelector rule+                    , isMatching context $ reverse selector ]++-- | Represent the content to apply to some+-- CSS matched rules.+data CssDeclaration = CssDeclaration+    { -- | Property name to change (like font-family or color).+      _cssDeclarationProperty :: T.Text+      -- | List of values+    , _cssDecarationlValues   :: [[CssElement]]+    }+    deriving (Eq, Show)++instance TextBuildable CssDeclaration where+  tserialize (CssDeclaration n elems) =+      mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems+     where+      finalElems = map tserialize (concat elems)+      ft = TB.fromText+      si = TB.singleton+++-- | Encode complex number possibly dependant to the current+-- render size.+data Number+  = Num Double       -- ^ Simple coordinate in current user coordinate.+  | Px Double        -- ^ With suffix "px"+  | Em Double        -- ^ Number relative to the current font size.+  | Percent Double   -- ^ Number relative to the current viewport size.+  | Pc Double+  | Mm Double        -- ^ Number in millimeters, relative to DPI.+  | Cm Double        -- ^ Number in centimeters, relative to DPI.+  | Point Double     -- ^ Number in points, relative to DPI.+  | Inches Double    -- ^ Number in inches, relative to DPI.+  deriving (Eq, Show)++-- | Helper function to modify inner value of a number+mapNumber :: (Double -> Double) -> Number -> Number+mapNumber f nu = case nu of+  Num n -> Num $ f n+  Px n -> Px $ f n+  Em n -> Em $ f n+  Percent n -> Percent $ f n+  Pc n -> Pc $ f n+  Mm n -> Mm $ f n+  Cm n -> Cm $ f n+  Point n -> Point $ f n+  Inches n -> Inches $ f n++-- | Encode the number to string which can be used in a+-- CSS or a svg attributes.+serializeNumber :: Number -> String+serializeNumber n = case n of+    Num c -> printf "%g" c+    Px c -> printf "%gpx" c+    Em cc -> printf "%gem" cc+    Percent p -> printf "%d%%" (floor $ 100 * p :: Int)+    Pc p -> printf "%gpc" p+    Mm m -> printf "%gmm" m+    Cm c -> printf "%gcm" c+    Point p -> printf "%gpt" p+    Inches i -> printf "%gin" i++instance TextBuildable Number where+   tserialize = TB.fromText . T.pack . serializeNumber++-- | Value of a CSS property.+data CssElement+    = CssIdent     !T.Text+    | CssString    !T.Text+    | CssReference !T.Text+    | CssNumber    !Number+    | CssColor     !PixelRGBA8+    | CssFunction  !T.Text ![CssElement]+    | CssOpComa+    | CssOpSlash+    deriving (Eq, Show)++instance TextBuildable CssElement where+  tserialize e = case e of+    CssIdent    n -> ft n+    CssString   s -> si '"' <> ft s <> si '"'+    CssReference r -> si '#' <> ft r+    CssNumber   n -> tserialize n+    CssColor  (PixelRGBA8 r g b _) ->+      ft . T.pack $ printf  "#%02X%02X%02X" r g b+    CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')']+        where args = intersperse (ft ", ") (map tserialize els)+    CssOpComa -> si ','+    CssOpSlash -> si '/'+    where+      ft = TB.fromText+      si = TB.singleton++-- | This function replace all device dependant units to user+-- units given it's DPI configuration.+-- Preserve percentage and "em" notation.+toUserUnit :: Dpi -> Number -> Number+toUserUnit dpi = go where+  go nu = case nu of+    Num _ -> nu+    Px p -> go $ Num p+    Em _ -> nu+    Percent _ -> nu+    Pc n -> go . Inches $ (12 * n) / 72+    Inches n -> Num $ n * fromIntegral dpi+    Mm n -> go . Inches $ n / 25.4+    Cm n -> go . Inches $ n / 2.54+    Point n -> go . Inches $ n / 72+

@@ -1,231 +1,260 @@-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
-module Graphics.Svg.PathParser( transformParser
-                              , command
-                              , pathParser
-                              , viewBoxParser
-                              , pointData
-                              , serializePoints
-                              , serializeCommand
-                              , serializeCommands
-                              , serializeViewBox
-                              ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) )
-#endif
-
-import Control.Applicative( (<|>) )
-import Data.Scientific( toRealFloat )
-import Data.Attoparsec.Text
-    ( Parser
-    , scientific
-    , string
-    , skipSpace
-    , char
-    , many1
-    )
-import Data.Attoparsec.Combinator( option
-                                 , sepBy
-                                 , sepBy1 )
-
-import Linear hiding ( angle, point )
-import Graphics.Svg.Types
-import qualified Data.Text as T
-import Text.Printf( printf )
-
-num :: Parser Double
-num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)
-  where doubleNumber :: Parser Double
-        doubleNumber = toRealFloat <$> scientific
-
-        plusMinus = negate <$ string "-" <*> doubleNumber
-                 <|> string "+" *> doubleNumber
-                 <|> doubleNumber
-
-viewBoxParser :: Parser (Double, Double, Double, Double)
-viewBoxParser = (,,,)
-       <$> iParse <*> iParse <*> iParse <*> iParse
-  where
-    iParse = num <* skipSpace
-
-serializeViewBox :: (Double, Double, Double, Double) -> String
-serializeViewBox (a, b, c, d) = printf "%g %g %g %g" a b c d
-
-commaWsp :: Parser ()
-commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace
-
-point :: Parser RPoint
-point = V2 <$> num <* commaWsp <*> num
-
-pointData :: Parser [RPoint]
-pointData = point `sepBy` commaWsp
-
-pathParser :: Parser [PathCommand]
-pathParser = skipSpace *> many1 command
-
-command :: Parser PathCommand
-command =  (MoveTo OriginAbsolute <$ string "M" <*> pointList)
-       <|> (MoveTo OriginRelative <$ string "m" <*> pointList)
-       <|> (LineTo OriginAbsolute <$ string "L" <*> pointList)
-       <|> (LineTo OriginRelative <$ string "l" <*> pointList)
-       <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList)
-       <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList)
-       <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList)
-       <|> (VerticalTo OriginRelative <$ string "v" <*> coordList)
-       <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs)
-       <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs)
-       <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList)
-       <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList)
-       <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList)
-       <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList)
-       <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList)
-       <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList)
-       <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs)
-       <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs)
-       <|> (EndPath <$ string "Z" <* commaWsp)
-       <|> (EndPath <$ string "z" <* commaWsp)
-    where pointList = point `sepBy1` commaWsp
-          pointPair = (,) <$> point <* commaWsp <*> point
-          pointPairList = pointPair `sepBy1` commaWsp
-          coordList = num `sepBy1` commaWsp
-          curveToArgs = (,,) <$> (point <* commaWsp)
-                             <*> (point <* commaWsp)
-                             <*> point
-          manyComma a = a `sepBy1` commaWsp
-
-          numComma = num <* commaWsp
-          ellipticalArgs = (,,,,,) <$> numComma
-                                   <*> numComma
-                                   <*> numComma
-                                   <*> (fmap (/= 0) numComma)
-                                   <*> (fmap (/= 0) numComma)
-                                   <*> point
-
-serializePoint :: RPoint -> String
-serializePoint (V2 x y) = printf "%g,%g" x y
-
-serializePoints :: [RPoint] -> String
-serializePoints = unwords . fmap serializePoint
-
-serializeCoords :: [Coord] -> String
-serializeCoords = unwords . fmap (printf "%g")
-
-serializePointPair :: (RPoint, RPoint) -> String
-serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b
-
-serializePointPairs :: [(RPoint, RPoint)] -> String
-serializePointPairs = unwords . fmap serializePointPair
-
-serializePointTriplet :: (RPoint, RPoint, RPoint) -> String
-serializePointTriplet (a, b, c) =
-    serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c
-
-serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String
-serializePointTriplets = unwords . fmap serializePointTriplet
-
-serializeCommands :: [PathCommand] -> String
-serializeCommands = unwords . fmap serializeCommand
-
-serializeCommand :: PathCommand -> String
-serializeCommand p = case p of
-  MoveTo OriginAbsolute points -> "M" ++ serializePoints points
-  MoveTo OriginRelative points -> "m" ++ serializePoints points
-  LineTo OriginAbsolute points -> "L" ++ serializePoints points
-  LineTo OriginRelative points -> "l" ++ serializePoints points
-
-  HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords
-  HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords
-  VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords
-  VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords
-
-  CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets
-  CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets
-  SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs
-  SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs
-  QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs
-  QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs
-  SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points
-  SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points
-  EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args
-  EllipticalArc OriginRelative args -> "a" ++ serializeArgs args
-  EndPath -> "Z"
-  where
-    serializeArg (a, b, c, d, e, V2 x y) =
-        printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y
-    serializeArgs = unwords . fmap serializeArg
-
-
-
-transformParser :: Parser Transformation
-transformParser = matrixParser
-               <|> translationParser
-               <|> scaleParser
-               <|> rotateParser
-               <|> skewYParser
-               <|> skewXParser
-
-functionParser :: T.Text -> Parser [Double]
-functionParser funcName =
-    string funcName *> skipSpace
-                    *> char '(' *> skipSpace
-                    *> num `sepBy1` commaWsp
-                    <* skipSpace <* char ')' <* skipSpace
-
-translationParser :: Parser Transformation
-translationParser = do
-  args <- functionParser "translate"
-  return $ case args of
-    [x] -> Translate x 0
-    [x, y] -> Translate x y
-    _ -> TransformUnknown
-
-skewXParser :: Parser Transformation
-skewXParser = do
-  args <- functionParser "skewX"
-  return $ case args of
-    [x] -> SkewX x
-    _ -> TransformUnknown
-
-skewYParser :: Parser Transformation
-skewYParser = do
-  args <- functionParser "skewY"
-  return $ case args of
-    [x] -> SkewY x
-    _ -> TransformUnknown
-
-
-scaleParser :: Parser Transformation
-scaleParser = do
-  args <- functionParser "scale"
-  return $ case args of
-    [x] -> Scale x Nothing
-    [x, y] -> Scale x (Just y)
-    _ -> TransformUnknown
-
-matrixParser :: Parser Transformation
-matrixParser = do
-  args <- functionParser "matrix"
-  return $ case args of
-    [a, b, c, d, e, f] ->
-        TransformMatrix a b c d e f
-    _ -> TransformUnknown
-
-rotateParser :: Parser Transformation
-rotateParser = do
-  args <- functionParser "rotate"
-  return $ case args of
-    [angle] -> Rotate angle Nothing
-    [angle, x, y] -> Rotate angle $ Just (x, y)
-    _ -> TransformUnknown
-{-
-rotate(<rotate-angle> [<cx> <cy>]), which specifies a rotation by <rotate-angle> degrees about a given point.
-
-If optional parameters <cx> and <cy> are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0].
-
-If optional parameters <cx> and <cy> are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(<cx>, <cy>) rotate(<rotate-angle>) translate(-<cx>, -<cy>).
-
-skewX(<skew-angle>), which specifies a skew transformation along the x-axis.
-
-skewY(<skew-angle>), which specifies a skew transformation along the y-axis.
-    -}
+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Graphics.Svg.PathParser( transformParser+                              , command+                              , pathParser+                              , viewBoxParser+                              , pointData+                              , gradientCommand+                              , serializePoints+                              , serializeCommand+                              , serializeGradientCommand +                              , serializeCommands+                              , serializeViewBox+                              ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) )+#endif++import Control.Applicative( (<|>) )+import Data.Scientific( toRealFloat )+import Data.Attoparsec.Text+    ( Parser+    , scientific+    , string+    , skipSpace+    , char+    , many1+    )+import Data.Attoparsec.Combinator( option+                                 , sepBy+                                 , sepBy1 )++import Linear hiding ( angle, point )+import Graphics.Svg.Types+import qualified Data.Text as T+import Text.Printf( printf )++num :: Parser Double+num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)+  where doubleNumber :: Parser Double+        doubleNumber = toRealFloat <$> scientific++        plusMinus = negate <$ string "-" <*> doubleNumber+                 <|> string "+" *> doubleNumber+                 <|> doubleNumber++viewBoxParser :: Parser (Double, Double, Double, Double)+viewBoxParser = (,,,)+       <$> iParse <*> iParse <*> iParse <*> iParse+  where+    iParse = num <* skipSpace++serializeViewBox :: (Double, Double, Double, Double) -> String+serializeViewBox (a, b, c, d) = printf "%g %g %g %g" a b c d++commaWsp :: Parser ()+commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace++point :: Parser RPoint+point = V2 <$> num <* commaWsp <*> num++pointData :: Parser [RPoint]+pointData = point `sepBy` commaWsp++pathParser :: Parser [PathCommand]+pathParser = skipSpace *> many1 command++command :: Parser PathCommand+command =  (MoveTo OriginAbsolute <$ string "M" <*> pointList)+       <|> (MoveTo OriginRelative <$ string "m" <*> pointList)+       <|> (LineTo OriginAbsolute <$ string "L" <*> pointList)+       <|> (LineTo OriginRelative <$ string "l" <*> pointList)+       <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList)+       <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList)+       <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList)+       <|> (VerticalTo OriginRelative <$ string "v" <*> coordList)+       <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs)+       <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs)+       <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList)+       <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList)+       <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList)+       <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList)+       <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList)+       <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList)+       <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs)+       <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs)+       <|> (EndPath <$ string "Z" <* commaWsp)+       <|> (EndPath <$ string "z" <* commaWsp)+    where pointList = point `sepBy1` commaWsp+          pointPair = (,) <$> point <* commaWsp <*> point+          pointPairList = pointPair `sepBy1` commaWsp+          coordList = num `sepBy1` commaWsp+          curveToArgs = (,,) <$> (point <* commaWsp)+                             <*> (point <* commaWsp)+                             <*> point+          manyComma a = a `sepBy1` commaWsp++          numComma = num <* commaWsp+          ellipticalArgs = (,,,,,) <$> numComma+                                   <*> numComma+                                   <*> numComma+                                   <*> (fmap (/= 0) numComma)+                                   <*> (fmap (/= 0) numComma)+                                   <*> point++serializePoint :: RPoint -> String+serializePoint (V2 x y) = printf "%g,%g" x y++serializePoints :: [RPoint] -> String+serializePoints = unwords . fmap serializePoint++serializeCoords :: [Coord] -> String+serializeCoords = unwords . fmap (printf "%g")++serializePointPair :: (RPoint, RPoint) -> String+serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b++serializePointPairs :: [(RPoint, RPoint)] -> String+serializePointPairs = unwords . fmap serializePointPair++serializePointTriplet :: (RPoint, RPoint, RPoint) -> String+serializePointTriplet (a, b, c) =+    serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c++serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String+serializePointTriplets = unwords . fmap serializePointTriplet++serializeCommands :: [PathCommand] -> String+serializeCommands = unwords . fmap serializeCommand++serializeCommand :: PathCommand -> String+serializeCommand p = case p of+  MoveTo OriginAbsolute points -> "M" ++ serializePoints points+  MoveTo OriginRelative points -> "m" ++ serializePoints points+  LineTo OriginAbsolute points -> "L" ++ serializePoints points+  LineTo OriginRelative points -> "l" ++ serializePoints points++  HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords+  HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords+  VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords+  VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords++  CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets+  CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets+  SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs+  SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs+  QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs+  QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs+  SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points+  SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points+  EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args+  EllipticalArc OriginRelative args -> "a" ++ serializeArgs args+  EndPath -> "Z"+  where+    serializeArg (a, b, c, d, e, V2 x y) =+        printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y+    serializeArgs = unwords . fmap serializeArg++++transformParser :: Parser Transformation+transformParser = matrixParser+               <|> translationParser+               <|> scaleParser+               <|> rotateParser+               <|> skewYParser+               <|> skewXParser++functionParser :: T.Text -> Parser [Double]+functionParser funcName =+    string funcName *> skipSpace+                    *> char '(' *> skipSpace+                    *> num `sepBy1` commaWsp+                    <* skipSpace <* char ')' <* skipSpace++translationParser :: Parser Transformation+translationParser = do+  args <- functionParser "translate"+  return $ case args of+    [x] -> Translate x 0+    [x, y] -> Translate x y+    _ -> TransformUnknown++skewXParser :: Parser Transformation+skewXParser = do+  args <- functionParser "skewX"+  return $ case args of+    [x] -> SkewX x+    _ -> TransformUnknown++skewYParser :: Parser Transformation+skewYParser = do+  args <- functionParser "skewY"+  return $ case args of+    [x] -> SkewY x+    _ -> TransformUnknown+++scaleParser :: Parser Transformation+scaleParser = do+  args <- functionParser "scale"+  return $ case args of+    [x] -> Scale x Nothing+    [x, y] -> Scale x (Just y)+    _ -> TransformUnknown++matrixParser :: Parser Transformation+matrixParser = do+  args <- functionParser "matrix"+  return $ case args of+    [a, b, c, d, e, f] ->+        TransformMatrix a b c d e f+    _ -> TransformUnknown++rotateParser :: Parser Transformation+rotateParser = do+  args <- functionParser "rotate"+  return $ case args of+    [angle] -> Rotate angle Nothing+    [angle, x, y] -> Rotate angle $ Just (x, y)+    _ -> TransformUnknown+{-+rotate(<rotate-angle> [<cx> <cy>]), which specifies a rotation by <rotate-angle> degrees about a given point.++If optional parameters <cx> and <cy> are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0].++If optional parameters <cx> and <cy> are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(<cx>, <cy>) rotate(<rotate-angle>) translate(-<cx>, -<cy>).++skewX(<skew-angle>), which specifies a skew transformation along the x-axis.++skewY(<skew-angle>), which specifies a skew transformation along the y-axis.+    -}+gradientCommand :: Parser GradientPathCommand+gradientCommand = +        (GLine OriginAbsolute <$> (string "L" *> mayPoint))+    <|> (GLine OriginRelative <$> (string "l" *> mayPoint))+    <|> (string "C" *> curveToArgs OriginAbsolute)+    <|> (string "c" *> curveToArgs OriginRelative)+    <|> (GClose <$ string "Z")+  where +    mayPoint = option Nothing $ Just <$> point+    curveToArgs o =+        GCurve o <$> (point <* commaWsp)+                 <*> (point <* commaWsp)+                 <*> mayPoint++serializeGradientCommand :: GradientPathCommand -> String+serializeGradientCommand p = case p of+  GLine OriginAbsolute points -> "L" ++ smp points+  GLine OriginRelative points -> "l" ++ smp points+  GClose -> "Z"++  GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c+  GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c+  where+    sp = serializePoint+    smp Nothing = ""+    smp (Just pp) = serializePoint pp+

@@ -1,1521 +1,1624 @@-{-# 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( .. )
-
-      -- ** 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)
-
--- | 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)
-
--- | 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
-
--- | 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 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
-    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
-
-  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
-    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
-
-  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"
-
-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
-
-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
-
-instance WithDrawAttributes Tree where
-    drawAttr = lens drawAttrOfTree setDrawAttrOfTree
-
-instance WithDefaultSvg Tree where
-    defaultSvg = None
-
--- | 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)
-
--- | 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 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
-    }
-    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
-    }
-
--- | 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
-    | 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+      -- | 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+

@@ -1,1164 +1,1227 @@-{-# 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 [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 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 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
-    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
-        ,"stop-color" `parseIn` gradientColor
-        ]
-
-
-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 _ = []
-
-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 -> "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 (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
-    "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
-      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 =+    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+                  ]+