svg-tree 0.5.1.1 → 0.5.1.2

raw patch · 9 files changed

+3787/−3779 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +60/−57
• src/Graphics/Svg.hs +111/−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 +231/−226
• src/Graphics/Svg/Types.hs +1521/−1521
• src/Graphics/Svg/XmlParser.hs +1164/−1164
• svg-tree.cabal +61/−61

@@ -1,57 +1,60 @@--*-change-log-*---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.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,111 @@-{-# 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
+      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,226 +1,231 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Graphics.Svg.PathParser( transformParser-                              , command-                              , 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-    )-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--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
+                              , 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.
+    -}

@@ -1,1521 +1,1521 @@-{-# 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( .. )
+
+      -- ** 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
+

@@ -1,1164 +1,1164 @@-{-# 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 $ many1 command-  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 [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
+                  ]
+