svg-tree 0.1.0.2 → 0.1.1

raw patch · 7 files changed

+1858/−1851 lines, 7 filesdep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: lens

API changes (from Hackage documentation)

Files

• changelog +14/−11
• src/Graphics/Svg.hs +111/−107
• src/Graphics/Svg/ColorParser.hs +111/−111
• src/Graphics/Svg/CssParser.hs +257/−257
• src/Graphics/Svg/PathParser.hs +226/−226
• src/Graphics/Svg/XmlParser.hs +1077/−1077
• svg-tree.cabal +62/−62

@@ -1,11 +1,14 @@--*-change-log-*-
-
-v0.1.0.2 March 2014
- * Fix: Bumping lens bounds
-
-v0.1.0.1
- * Fix: Lowering some lower bounds
-
-v0.1
- * Initial release
-
+-*-change-log-*-++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,107 +1,111 @@--- | 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
-
-import Control.Applicative( (<$>) )
-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 Float
-        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 Float+        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 Float
-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 [Float]
-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 Float+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 [Float]+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,226 +1,226 @@-{-# 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 Float
-num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)
-  where doubleNumber :: Parser Float
-        doubleNumber = toRealFloat <$> scientific
-
-        plusMinus = negate <$ string "-" <*> doubleNumber
-                 <|> string "+" *> doubleNumber
-                 <|> doubleNumber
-
-viewBoxParser :: Parser (Int, Int, Int, Int)
-viewBoxParser = (,,,)
-       <$> iParse <*> iParse <*> iParse <*> iParse
-  where
-    iParse = floor <$> num <* skipSpace
-
-serializeViewBox :: (Int, Int, Int, Int) -> String
-serializeViewBox (a, b, c, d) = printf "%d %d %d %d" 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)
-       <|> (ElipticalArc OriginAbsolute <$ string "A" <*> manyComma elipticalArgs)
-       <|> (ElipticalArc OriginRelative <$ string "a" <*> manyComma elipticalArgs)
-       <|> (EndPath <$ string "Z")
-       <|> (EndPath <$ string "z")
-    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
-          elipticalArgs = (,,,,,) <$> numComma
-                                  <*> numComma
-                                  <*> numComma
-                                  <*> numComma
-                                  <*> 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
-  ElipticalArc OriginAbsolute args -> "A" ++ serializeArgs args
-  ElipticalArc OriginRelative args -> "a" ++ serializeArgs args
-  EndPath -> "Z"
-  where
-    serializeArg (a, b, c, d, e, V2 x y) =
-        printf "%g %g %g %g %g %g,%g" a b c d e x y
-    serializeArgs = unwords . fmap serializeArg 
-
-
-
-transformParser :: Parser Transformation
-transformParser = matrixParser
-               <|> translationParser
-               <|> scaleParser
-               <|> rotateParser
-               <|> skewYParser
-               <|> skewXParser
-
-functionParser :: T.Text -> Parser [Float]
-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+                              , 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 Float+num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)+  where doubleNumber :: Parser Float+        doubleNumber = toRealFloat <$> scientific++        plusMinus = negate <$ string "-" <*> doubleNumber+                 <|> string "+" *> doubleNumber+                 <|> doubleNumber++viewBoxParser :: Parser (Int, Int, Int, Int)+viewBoxParser = (,,,)+       <$> iParse <*> iParse <*> iParse <*> iParse+  where+    iParse = floor <$> num <* skipSpace++serializeViewBox :: (Int, Int, Int, Int) -> String+serializeViewBox (a, b, c, d) = printf "%d %d %d %d" 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)+       <|> (ElipticalArc OriginAbsolute <$ string "A" <*> manyComma elipticalArgs)+       <|> (ElipticalArc OriginRelative <$ string "a" <*> manyComma elipticalArgs)+       <|> (EndPath <$ string "Z")+       <|> (EndPath <$ string "z")+    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+          elipticalArgs = (,,,,,) <$> numComma+                                  <*> numComma+                                  <*> numComma+                                  <*> numComma+                                  <*> 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+  ElipticalArc OriginAbsolute args -> "A" ++ serializeArgs args+  ElipticalArc OriginRelative args -> "a" ++ serializeArgs args+  EndPath -> "Z"+  where+    serializeArg (a, b, c, d, e, V2 x y) =+        printf "%g %g %g %g %g %g,%g" a b c d e x y+    serializeArgs = unwords . fmap serializeArg ++++transformParser :: Parser Transformation+transformParser = matrixParser+               <|> translationParser+               <|> scaleParser+               <|> rotateParser+               <|> skewYParser+               <|> skewXParser++functionParser :: T.Text -> Parser [Float]+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,1077 +1,1077 @@-{-# 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,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( catMaybes )
-import Data.Monoid( Last( Last ), getLast, (<>) )
-import Data.List( foldl', intercalate )
-import Text.XML.Light.Proc( findAttrBy, elChildren, strContent )
-import Text.Read( readMaybe )
-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-}
-
-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 Float 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 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 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 (Int, Int, Int, Int) 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 -> X.Element
-
-setChildren :: X.Element -> [X.Content] -> X.Element
-setChildren xNode children = xNode { X.elContent = children }
-
-updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> X.Element -> X.Element
-updateWithAccessor accessor node xNode =
-    setChildren xNode $ X.Elem . serializeTreeNode <$> accessor node
-
-genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> X.Element
-genericSerializeNode node =
-    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 -> X.Element
-genericSerializeWithDrawAttr node = mergeAttributes thisXml drawAttrNode where
-  thisXml = genericSerializeNode node
-  drawAttrNode = genericSerializeNode $ node ^. drawAttr
-
-type CssUpdater =
-    DrawAttributes -> [[CssElement]] -> DrawAttributes
-
-groupOpacitySetter :: SvgAttributeLens DrawAttributes
-groupOpacitySetter = SvgAttributeLens "opacity" updater serializer
-  where
-    updater el str = case parseMayStartDot num str of
-        Nothing -> el
-        Just v -> (el & fillOpacity .~ Just v) & strokeOpacity .~ Just v
-
-    serializer a = case (a ^. fillOpacity, a ^. strokeOpacity) of
-      (Just v, Just b) | v == b -> Just $ printf "%g" v
-      _ -> Nothing
-
-opacitySetter :: String -> Lens' a (Maybe Float) -> Lens' a (Maybe Float)
-              -> SvgAttributeLens a
-opacitySetter attribute elLens otherLens =
-    SvgAttributeLens attribute updater serializer
-  where
-    updater el str = case parseMayStartDot num str of
-        Nothing -> el
-        Just v -> el & elLens .~ Just v
-
-    serializer a = case (a ^. elLens, a ^. otherLens) of
-        (Just v, Just b) | v == b -> Nothing
-        (Just v, _) -> Just $ printf "%g" v
-        (Nothing, _) -> Nothing
-
-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 = 
-       Just . T.unpack . T.intercalate " " $ a ^. attrClass
-
-cssUniqueNumber :: ASetter DrawAttributes DrawAttributes
-                   a (Last Number)
-                -> CssUpdater
-cssUniqueNumber setter attr ((CssNumber n:_):_) =
-    attr & setter .~ Last (Just n)
-cssUniqueNumber _ attr _ = attr
-
-cssUniqueFloat :: ASetter DrawAttributes DrawAttributes a (Maybe Float)
-               -> CssUpdater
-cssUniqueFloat setter attr ((CssNumber (Num n):_):_) =
-    attr & setter .~ Just n
-cssUniqueFloat _ attr _ = attr
-
-cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Float)
-               -> 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)
-  ,(groupOpacitySetter, cssUniqueFloat fillOpacity)
-  ,(opacitySetter "fill-opacity" fillOpacity strokeOpacity,
-      cssUniqueFloat fillOpacity)
-  ,(opacitySetter "stroke-opacity" strokeOpacity fillOpacity,
-      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 . ('#':))
-    ]
-
-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 -> X.blank_element
-    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 ->
-        setChildren textNode [X.Elem . setChildren pathNode $ X.elContent textNode]
-      where
-        textNode = serializeTreeNode t
-        pathNode = serializeTreeNode p
-
-
-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)]
-
-
-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)
-    ]
-
-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
-    ]
-
-serializeText :: Text -> X.Element
-serializeText topText = topNode { X.elName = X.unqual "text" } where
-  topNode = serializeSpan $ _textRoot topText 
-  
-  serializeSpan tspan = setChildren (mergeAttributes info drawInfo) subContent
-    where
-      info = genericSerializeNode $ _spanInfo tspan
-      drawInfo = genericSerializeNode $ _spanDrawAttributes tspan
-      subContent = serializeContent <$> _spanContent tspan
-
-  serializeContent (SpanText t) = X.Text $ X.blank_cdata { X.cdData = T.unpack t }
-  serializeContent (SpanTextRef _t) = 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 = 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 = [serializeTreeNode el | el <- _elements doc, isNotNone el ]
-
-    defsTag | null defs = []
-            | otherwise = [X.node (X.unqual "defs") defs]
-
-    defs = [elementRender k e | (k, e) <- M.assocs $ _definitions doc
-                              , isElementNotNone e]
-
-    isElementNotNone (ElementGeometry el) = isNotNone el
-    isElementNotNone _ = True
-
-    elementRender k e = case e of
-        ElementGeometry t -> serializeTreeNode t
-        ElementMarker m -> serializeTreeNode m
-        ElementMask m -> serializeTreeNode m
-        ElementClipPath c -> serializeTreeNode c
-        ElementPattern p ->
-            X.add_attr (attr "id" k) $ serializeTreeNode p
-        ElementLinearGradient lg ->
-            X.add_attr (attr "id" k) $ serializeTreeNode lg
-        ElementRadialGradient rg ->
-            X.add_attr (attr "id" k) $ serializeTreeNode rg
-
-    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,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( catMaybes )+import Data.Monoid( Last( Last ), getLast, (<>) )+import Data.List( foldl', intercalate )+import Text.XML.Light.Proc( findAttrBy, elChildren, strContent )+import Text.Read( readMaybe )+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-}++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 Float 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 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 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 (Int, Int, Int, Int) 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 -> X.Element++setChildren :: X.Element -> [X.Content] -> X.Element+setChildren xNode children = xNode { X.elContent = children }++updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> X.Element -> X.Element+updateWithAccessor accessor node xNode =+    setChildren xNode $ X.Elem . serializeTreeNode <$> accessor node++genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> X.Element+genericSerializeNode node =+    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 -> X.Element+genericSerializeWithDrawAttr node = mergeAttributes thisXml drawAttrNode where+  thisXml = genericSerializeNode node+  drawAttrNode = genericSerializeNode $ node ^. drawAttr++type CssUpdater =+    DrawAttributes -> [[CssElement]] -> DrawAttributes++groupOpacitySetter :: SvgAttributeLens DrawAttributes+groupOpacitySetter = SvgAttributeLens "opacity" updater serializer+  where+    updater el str = case parseMayStartDot num str of+        Nothing -> el+        Just v -> (el & fillOpacity .~ Just v) & strokeOpacity .~ Just v++    serializer a = case (a ^. fillOpacity, a ^. strokeOpacity) of+      (Just v, Just b) | v == b -> Just $ printf "%g" v+      _ -> Nothing++opacitySetter :: String -> Lens' a (Maybe Float) -> Lens' a (Maybe Float)+              -> SvgAttributeLens a+opacitySetter attribute elLens otherLens =+    SvgAttributeLens attribute updater serializer+  where+    updater el str = case parseMayStartDot num str of+        Nothing -> el+        Just v -> el & elLens .~ Just v++    serializer a = case (a ^. elLens, a ^. otherLens) of+        (Just v, Just b) | v == b -> Nothing+        (Just v, _) -> Just $ printf "%g" v+        (Nothing, _) -> Nothing++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 = +       Just . T.unpack . T.intercalate " " $ a ^. attrClass++cssUniqueNumber :: ASetter DrawAttributes DrawAttributes+                   a (Last Number)+                -> CssUpdater+cssUniqueNumber setter attr ((CssNumber n:_):_) =+    attr & setter .~ Last (Just n)+cssUniqueNumber _ attr _ = attr++cssUniqueFloat :: ASetter DrawAttributes DrawAttributes a (Maybe Float)+               -> CssUpdater+cssUniqueFloat setter attr ((CssNumber (Num n):_):_) =+    attr & setter .~ Just n+cssUniqueFloat _ attr _ = attr++cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Float)+               -> 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)+  ,(groupOpacitySetter, cssUniqueFloat fillOpacity)+  ,(opacitySetter "fill-opacity" fillOpacity strokeOpacity,+      cssUniqueFloat fillOpacity)+  ,(opacitySetter "stroke-opacity" strokeOpacity fillOpacity,+      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 . ('#':))+    ]++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 -> X.blank_element+    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 ->+        setChildren textNode [X.Elem . setChildren pathNode $ X.elContent textNode]+      where+        textNode = serializeTreeNode t+        pathNode = serializeTreeNode p+++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)]+++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)+    ]++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+    ]++serializeText :: Text -> X.Element+serializeText topText = topNode { X.elName = X.unqual "text" } where+  topNode = serializeSpan $ _textRoot topText +  +  serializeSpan tspan = setChildren (mergeAttributes info drawInfo) subContent+    where+      info = genericSerializeNode $ _spanInfo tspan+      drawInfo = genericSerializeNode $ _spanDrawAttributes tspan+      subContent = serializeContent <$> _spanContent tspan++  serializeContent (SpanText t) = X.Text $ X.blank_cdata { X.cdData = T.unpack t }+  serializeContent (SpanTextRef _t) = 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 = 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 = [serializeTreeNode el | el <- _elements doc, isNotNone el ]++    defsTag | null defs = []+            | otherwise = [X.node (X.unqual "defs") defs]++    defs = [elementRender k e | (k, e) <- M.assocs $ _definitions doc+                              , isElementNotNone e]++    isElementNotNone (ElementGeometry el) = isNotNone el+    isElementNotNone _ = True++    elementRender k e = case e of+        ElementGeometry t -> serializeTreeNode t+        ElementMarker m -> serializeTreeNode m+        ElementMask m -> serializeTreeNode m+        ElementClipPath c -> serializeTreeNode c+        ElementPattern p ->+            X.add_attr (attr "id" k) $ serializeTreeNode p+        ElementLinearGradient lg ->+            X.add_attr (attr "id" k) $ serializeTreeNode lg+        ElementRadialGradient rg ->+            X.add_attr (attr "id" k) $ serializeTreeNode rg++    docViewBox = case _viewBox doc of+        Nothing -> []+        Just b -> [attr "viewBox" $ serializeViewBox b]++    descTag = case _description doc of+        "" -> []+        txt -> [X.node (X.unqual "desc") txt]++    styleTag = case _styleRules doc of+        [] -> []+        rules -> [X.node (X.unqual "style")+                        ([attr "type" "text/css"], txt)]+          where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules++    attrs =+        docViewBox +++        [attr "xmlns" "http://www.w3.org/2000/svg"+        ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink"+        ,attr "version" "1.1"] +++        catMaybes [attr "width" . serializeNumber <$> _width doc+                  ,attr "height" . serializeNumber <$> _height doc+                  ]+

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