reanimate-svg (empty) → 0.7.0.0

raw patch · 14 files changed

+5326/−0 lines, 14 filesdep +JuicyPixelsdep +attoparsecdep +basesetup-changed

Dependencies added: JuicyPixels, attoparsec, base, bytestring, containers, fail, hspec, lens, linear, mtl, scientific, semigroups, svg-tree, text, transformers, vector, xml

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• changelog.md +95/−0
• reanimate-svg.cabal +74/−0
• src/Graphics/SvgTree.hs +101/−0
• src/Graphics/SvgTree/ColorParser.hs +100/−0
• src/Graphics/SvgTree/CssParser.hs +231/−0
• src/Graphics/SvgTree/CssTypes.hs +270/−0
• src/Graphics/SvgTree/NamedColors.hs +157/−0
• src/Graphics/SvgTree/PathParser.hs +256/−0
• src/Graphics/SvgTree/Types.hs +2787/−0
• src/Graphics/SvgTree/XmlParser.hs +1204/−0
• test/PathParserSpec.hs +18/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,30 @@+Copyright (c) 2013, Vincent Berthoux++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Vincent Berthoux nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,95 @@+-*-change-log-*-++v0.7.0.0 March 2019++ * fork from svg-tree due to 'reanimate' requiring breaking changes+ * Fix: change x,y rect defaults from '0' to 'auto'.+ * Expose list of named svg colors.+ * Adding: Allow definitions to appear anywhere in an svg document.+ * Change module namespace from Graphics.Svg to Graphics.SvgTree++v0.6.2.3 October 2018++ * GHC 8.6 fixes+ * Adding: Allow definitions to appear anywhere in an svg document.++v0.6.2.2 December 2017++ * Adding `Semigroup` instances for defined `Monoid`, for GHC 8.4++v0.6.2.1 December 2017+ * Workaround/Fix: removed reliance on Template Haskell to derive lenses,+   by writing them directly in the file, using the ddump-splices. For some+   reason Haddock associated with GHC 8.2.2 was entering infinite loop on+   the Types file. Ugly workaround, but at least it works.++v0.6.2 August 2017+ * Fix: gather named elements even outside of <defs> tags.+ * Fix: URL ID now can contain more characters.++v0.6.1: January 2017+ * Fix: some gradient mesh parsing, stop can have style (like with Inkscape 0.92)+ * Fix: norm say "<mesh>" is the global tag+ * Fix: Adding `xlink:href` attribute on patterns+ * Fix: Adding `patternTransform` attribute on patterns++v0.6: September 2016+ * Add SVG 2.0 gradient mesh++v0.5.1.2: September 2016+ * Fix path parsing with white space prefix++v0.5.1.1: May 2016+ * Fix: GHC 8.0 compatibility++v0.5.1: March 2016+ * Fix: serialization of multi criteria css selector.++v0.5: March 2016:+ * Adding: preserveAspectRatio attribute+ * Fix: Application of CSS rules with indirect parent/child relation.++v0.4.2: March 2016+ * Enhancement: avoiding serializatinon of empty class attribute+ * Fix: incorrect deserialization of complex CSS+ * Fix: Really fixing duplicate ID with serialization++v0.4.1: February 2016+ * Fix: fixing duplicate ID with serialization++v0.4: February 2016+ * Breaking change: viewbox types are no longer Int+   but double, sneakingly passed in v0.3.2.2. This+   version acknoweledge this change++V0.3.2.2 February 2016 (Deprecated)+ * Fix: Bad serialization of some None constructors.++v0.3.2.1 October 2015+ * Fix: Don't add '#' for <img> serialization++v0.3.2 August 2015+ * Fix: allow compilation with GHC 7.4++v0.3.1 May 2015+ * Fix: Bumping lens dependency and removing upper bound.++v0.3 April 2015+ * Breaking change: Switching all the numeric types associated to geometry+   to Double precision (thx to Kasbah)++v0.2 April 2015+ * Fix: Differentiating opacity & fill-opacity, as they are+   semantically deferent (BREAKING CHANGE!)++v0.1.1 April 2015+ * Fix: Bumping lens bounds++v0.1.0.2 March 2015+ * Fix: Bumping lens bounds++v0.1.0.1+ * Fix: Lowering some lower bounds++v0.1+ * Initial release

@@ -0,0 +1,74 @@+name:                reanimate-svg+version:             0.7.0.0+synopsis:            SVG file loader and serializer+description:+  reanimate-svg 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`.+++license:             BSD3+license-file:        LICENSE+author:              Vincent Berthoux, David Himmelstrup+maintainer:          David Himmelstrup <lemmih@gmail.com>+-- copyright:+category:            Graphics, Svg+build-type:          Simple+cabal-version:       >=1.10++extra-source-files: changelog.md++Source-Repository head+    Type:      git+    Location:  git://github.com/lemmih/reanimate-svg.git++library+  hs-source-dirs: src+  Ghc-options: -O3 -Wall+  default-language: Haskell2010+  exposed-modules: Graphics.SvgTree+                 , Graphics.SvgTree.CssTypes+                 , Graphics.SvgTree.Types+                 , Graphics.SvgTree.PathParser+                 , Graphics.SvgTree.NamedColors++  other-modules: Graphics.SvgTree.XmlParser+               , Graphics.SvgTree.CssParser+               , Graphics.SvgTree.ColorParser++  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  else+    -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8+    build-depends: fail == 4.9.*, semigroups == 0.18.*++  build-depends: base >= 4.5 && < 6+               , JuicyPixels >= 3.2+               , attoparsec >= 0.12+               , scientific >= 0.3+               , containers >= 0.4+               , xml        >= 1.3+               , bytestring >= 0.10+               , linear     >= 1.20+               , vector     >= 0.10+               , text       >= 1.1+               , transformers >= 0.3 && < 0.6+               , mtl        >= 2.1 && < 2.3+               , lens       >= 4.6 && < 5++test-suite test+  default-language: Haskell2010+  hs-source-dirs: test+  main-is: Spec.hs+  type: exitcode-stdio-1.0+  build-depends: base+               , svg-tree+               , attoparsec >= 0.12+               , scientific >= 0.3+               , linear     >= 1.20+               , hspec+  ghc-options: -Wall -threaded+  other-modules: PathParserSpec

@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+-- | Module providing basic input/output for the SVG document,+-- for document building, please refer to Graphics.Svg.Types.+module Graphics.SvgTree+  ( -- * Saving/Loading functions+    loadSvgFile+  , parseSvgFile+  , xmlOfDocument+  , saveXmlFile++    -- * Manipulation functions+  , cssApply+  , cssRulesOfText+  , applyCSSRules+  , resolveUses++    -- * Type definitions+  , module Graphics.SvgTree.Types+  ) where++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative        ((<$>))+#endif++import           Control.Lens+import qualified Data.ByteString            as B+import           Data.List                  (foldl')+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           Graphics.SvgTree.CssParser (cssRulesOfText)+import           Graphics.SvgTree.CssTypes+import           Graphics.SvgTree.Types+import           Graphics.SvgTree.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 = M.lookup (_useName nfo) $ _definitions doc++-- | Rewrite the document by applying the CSS rules embedded+-- inside it.+applyCSSRules :: Document -> Document+applyCSSRules doc = doc+    { _elements = cssApply (_styleRules doc) <$> _elements doc }

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

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

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

@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}+module Graphics.SvgTree.NamedColors( svgNamedColors ) where++import           Codec.Picture (PixelRGBA8 (..))+import qualified Data.Map      as M+import           Data.Text     (Text)++svgNamedColors :: M.Map Text PixelRGBA8+svgNamedColors = M.fromList+  [ ("aliceblue"           , PixelRGBA8 240 248 255 255)+  , ("antiquewhite"        , PixelRGBA8 250 235 215 255)+  , ("aqua"                , PixelRGBA8   0 255 255 255)+  , ("aquamarine"          , PixelRGBA8 127 255 212 255)+  , ("azure"               , PixelRGBA8 240 255 255 255)+  , ("beige"               , PixelRGBA8 245 245 220 255)+  , ("bisque"              , PixelRGBA8 255 228 196 255)+  , ("black"               , PixelRGBA8   0   0   0 255)+  , ("blanchedalmond"      , PixelRGBA8 255 235 205 255)+  , ("blue"                , PixelRGBA8   0   0 255 255)+  , ("blueviolet"          , PixelRGBA8 138  43 226 255)+  , ("brown"               , PixelRGBA8 165  42  42 255)+  , ("burlywood"           , PixelRGBA8 222 184 135 255)+  , ("cadetblue"           , PixelRGBA8  95 158 160 255)+  , ("chartreuse"          , PixelRGBA8 127 255   0 255)+  , ("chocolate"           , PixelRGBA8 210 105  30 255)+  , ("coral"               , PixelRGBA8 255 127  80 255)+  , ("cornflowerblue"      , PixelRGBA8 100 149 237 255)+  , ("cornsilk"            , PixelRGBA8 255 248 220 255)+  , ("crimson"             , PixelRGBA8 220  20  60 255)+  , ("cyan"                , PixelRGBA8   0 255 255 255)+  , ("darkblue"            , PixelRGBA8   0   0 139 255)+  , ("darkcyan"            , PixelRGBA8   0 139 139 255)+  , ("darkgoldenrod"       , PixelRGBA8 184 134  11 255)+  , ("darkgray"            , PixelRGBA8 169 169 169 255)+  , ("darkgreen"           , PixelRGBA8   0 100   0 255)+  , ("darkgrey"            , PixelRGBA8 169 169 169 255)+  , ("darkkhaki"           , PixelRGBA8 189 183 107 255)+  , ("darkmagenta"         , PixelRGBA8 139   0 139 255)+  , ("darkolivegreen"      , PixelRGBA8  85 107  47 255)+  , ("darkorange"          , PixelRGBA8 255 140   0 255)+  , ("darkorchid"          , PixelRGBA8 153  50 204 255)+  , ("darkred"             , PixelRGBA8 139   0   0 255)+  , ("darksalmon"          , PixelRGBA8 233 150 122 255)+  , ("darkseagreen"        , PixelRGBA8 143 188 143 255)+  , ("darkslateblue"       , PixelRGBA8  72  61 139 255)+  , ("darkslategray"       , PixelRGBA8  47  79  79 255)+  , ("darkslategrey"       , PixelRGBA8  47  79  79 255)+  , ("darkturquoise"       , PixelRGBA8   0 206 209 255)+  , ("darkviolet"          , PixelRGBA8 148   0 211 255)+  , ("deeppink"            , PixelRGBA8 255  20 147 255)+  , ("deepskyblue"         , PixelRGBA8   0 191 255 255)+  , ("dimgray"             , PixelRGBA8 105 105 105 255)+  , ("dimgrey"             , PixelRGBA8 105 105 105 255)+  , ("dodgerblue"          , PixelRGBA8  30 144 255 255)+  , ("firebrick"           , PixelRGBA8 178  34  34 255)+  , ("floralwhite"         , PixelRGBA8 255 250 240 255)+  , ("forestgreen"         , PixelRGBA8  34 139  34 255)+  , ("fuchsia"             , PixelRGBA8 255   0 255 255)+  , ("gainsboro"           , PixelRGBA8 220 220 220 255)+  , ("ghostwhite"          , PixelRGBA8 248 248 255 255)+  , ("gold"                , PixelRGBA8 255 215   0 255)+  , ("goldenrod"           , PixelRGBA8 218 165  32 255)+  , ("gray"                , PixelRGBA8 128 128 128 255)+  , ("grey"                , PixelRGBA8 128 128 128 255)+  , ("green"               , PixelRGBA8   0 128   0 255)+  , ("greenyellow"         , PixelRGBA8 173 255  47 255)+  , ("honeydew"            , PixelRGBA8 240 255 240 255)+  , ("hotpink"             , PixelRGBA8 255 105 180 255)+  , ("indianred"           , PixelRGBA8 205  92  92 255)+  , ("indigo"              , PixelRGBA8  75   0 130 255)+  , ("ivory"               , PixelRGBA8 255 255 240 255)+  , ("khaki"               , PixelRGBA8 240 230 140 255)+  , ("lavender"            , PixelRGBA8 230 230 250 255)+  , ("lavenderblush"       , PixelRGBA8 255 240 245 255)+  , ("lawngreen"           , PixelRGBA8 124 252   0 255)+  , ("lemonchiffon"        , PixelRGBA8 255 250 205 255)+  , ("lightblue"           , PixelRGBA8 173 216 230 255)+  , ("lightcoral"          , PixelRGBA8 240 128 128 255)+  , ("lightcyan"           , PixelRGBA8 224 255 255 255)+  , ("lightgoldenrodyellow", PixelRGBA8 250 250 210 255)+  , ("lightgray"           , PixelRGBA8 211 211 211 255)+  , ("lightgreen"          , PixelRGBA8 144 238 144 255)+  , ("lightgrey"           , PixelRGBA8 211 211 211 255)+  , ("lightpink"           , PixelRGBA8 255 182 193 255)+  , ("lightsalmon"         , PixelRGBA8 255 160 122 255)+  , ("lightseagreen"       , PixelRGBA8  32 178 170 255)+  , ("lightskyblue"        , PixelRGBA8 135 206 250 255)+  , ("lightslategray"      , PixelRGBA8 119 136 153 255)+  , ("lightslategrey"      , PixelRGBA8 119 136 153 255)+  , ("lightsteelblue"      , PixelRGBA8 176 196 222 255)+  , ("lightyellow"         , PixelRGBA8 255 255 224 255)+  , ("lime"                , PixelRGBA8   0 255   0 255)+  , ("limegreen"           , PixelRGBA8  50 205  50 255)+  , ("linen"               , PixelRGBA8 250 240 230 255)+  , ("magenta"             , PixelRGBA8 255   0 255 255)+  , ("maroon"              , PixelRGBA8 128   0   0 255)+  , ("mediumaquamarine"    , PixelRGBA8 102 205 170 255)+  , ("mediumblue"          , PixelRGBA8   0   0 205 255)+  , ("mediumorchid"        , PixelRGBA8 186  85 211 255)+  , ("mediumpurple"        , PixelRGBA8 147 112 219 255)+  , ("mediumseagreen"      , PixelRGBA8  60 179 113 255)+  , ("mediumslateblue"     , PixelRGBA8 123 104 238 255)+  , ("mediumspringgreen"   , PixelRGBA8   0 250 154 255)+  , ("mediumturquoise"     , PixelRGBA8  72 209 204 255)+  , ("mediumvioletred"     , PixelRGBA8 199  21 133 255)+  , ("midnightblue"        , PixelRGBA8  25  25 112 255)+  , ("mintcream"           , PixelRGBA8 245 255 250 255)+  , ("mistyrose"           , PixelRGBA8 255 228 225 255)+  , ("moccasin"            , PixelRGBA8 255 228 181 255)+  , ("navajowhite"         , PixelRGBA8 255 222 173 255)+  , ("navy"                , PixelRGBA8   0   0 128 255)+  , ("oldlace"             , PixelRGBA8 253 245 230 255)+  , ("olive"               , PixelRGBA8 128 128   0 255)+  , ("olivedrab"           , PixelRGBA8 107 142  35 255)+  , ("orange"              , PixelRGBA8 255 165   0 255)+  , ("orangered"           , PixelRGBA8 255  69   0 255)+  , ("orchid"              , PixelRGBA8 218 112 214 255)+  , ("palegoldenrod"       , PixelRGBA8 238 232 170 255)+  , ("palegreen"           , PixelRGBA8 152 251 152 255)+  , ("paleturquoise"       , PixelRGBA8 175 238 238 255)+  , ("palevioletred"       , PixelRGBA8 219 112 147 255)+  , ("papayawhip"          , PixelRGBA8 255 239 213 255)+  , ("peachpuff"           , PixelRGBA8 255 218 185 255)+  , ("peru"                , PixelRGBA8 205 133  63 255)+  , ("pink"                , PixelRGBA8 255 192 203 255)+  , ("plum"                , PixelRGBA8 221 160 221 255)+  , ("powderblue"          , PixelRGBA8 176 224 230 255)+  , ("purple"              , PixelRGBA8 128   0 128 255)+  , ("red"                 , PixelRGBA8 255   0   0 255)+  , ("rosybrown"           , PixelRGBA8 188 143 143 255)+  , ("royalblue"           , PixelRGBA8  65 105 225 255)+  , ("saddlebrown"         , PixelRGBA8 139  69  19 255)+  , ("salmon"              , PixelRGBA8 250 128 114 255)+  , ("sandybrown"          , PixelRGBA8 244 164  96 255)+  , ("seagreen"            , PixelRGBA8  46 139  87 255)+  , ("seashell"            , PixelRGBA8 255 245 238 255)+  , ("sienna"              , PixelRGBA8 160  82  45 255)+  , ("silver"              , PixelRGBA8 192 192 192 255)+  , ("skyblue"             , PixelRGBA8 135 206 235 255)+  , ("slateblue"           , PixelRGBA8 106  90 205 255)+  , ("slategray"           , PixelRGBA8 112 128 144 255)+  , ("slategrey"           , PixelRGBA8 112 128 144 255)+  , ("snow"                , PixelRGBA8 255 250 250 255)+  , ("springgreen"         , PixelRGBA8   0 255 127 255)+  , ("steelblue"           , PixelRGBA8  70 130 180 255)+  , ("tan"                 , PixelRGBA8 210 180 140 255)+  , ("teal"                , PixelRGBA8   0 128 128 255)+  , ("thistle"             , PixelRGBA8 216 191 216 255)+  , ("tomato"              , PixelRGBA8 255  99  71 255)+  , ("turquoise"           , PixelRGBA8  64 224 208 255)+  , ("violet"              , PixelRGBA8 238 130 238 255)+  , ("wheat"               , PixelRGBA8 245 222 179 255)+  , ("white"               , PixelRGBA8 255 255 255 255)+  , ("whitesmoke"          , PixelRGBA8 245 245 245 255)+  , ("yellow"              , PixelRGBA8 255 255   0 255)+  , ("yellowgreen"         , PixelRGBA8 154 205  50 255)+  ]

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

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

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

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+module PathParserSpec where++import Data.Attoparsec.Text+import Graphics.Svg.PathParser+import Graphics.Svg.Types+import Linear+import Test.Hspec+++spec :: Spec+spec = do+  describe "num" $ do+    it "support shorthand number" $ do+      parseOnly command d `shouldBe` Right p+      where+        d = "M-.10 .10z"+        p = MoveTo OriginAbsolute [V2 (-0.1) 0.10]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}