reanimate-svg 0.7.0.0 → 0.8.0.0

raw patch · 5 files changed

+626/−516 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +6/−0
• reanimate-svg.cabal +1/−1
• src/Graphics/SvgTree.hs +8/−8
• src/Graphics/SvgTree/Types.hs +439/−396
• src/Graphics/SvgTree/XmlParser.hs +172/−111

@@ -1,5 +1,11 @@ -*-change-log-*- +v0.8.0.0 March 2019++ * Remove WithDrawAttributes type class.+ * Remove css and top-level definitions from Document.+ * Basic support for SVG filters.+ v0.7.0.0 March 2019   * fork from svg-tree due to 'reanimate' requiring breaking changes

@@ -1,5 +1,5 @@ name:                reanimate-svg-version:             0.7.0.0+version:             0.8.0.0 synopsis:            SVG file loader and serializer description:   reanimate-svg provides types representing a SVG document,

@@ -11,7 +11,7 @@     -- * Manipulation functions   , cssApply   , cssRulesOfText-  , applyCSSRules+  -- , applyCSSRules   , resolveUses      -- * Type definitions@@ -74,11 +74,11 @@ cssApply rules = zipTree go where   go [] = None   go ([]:_) = None-  go context@((t:_):_) = t & drawAttr .~ attr'+  go context@((t:_):_) = t & drawAttributes .~ attr'    where      matchingDeclarations =          findMatchingDeclarations rules context-     attr = view drawAttr t+     attr = view drawAttributes t      attr' = foldl' cssDeclApplyer attr matchingDeclarations  -- | For every 'use' tag, try to resolve the geometry associated@@ -94,8 +94,8 @@      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 }+-- -- | Rewrite the document by applying the CSS rules embedded+-- -- inside it.+-- applyCSSRules :: Document -> Document+-- applyCSSRules doc = doc+--     { _elements = cssApply (_styleRules doc) <$> _elements doc }

@@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE OverloadedStrings      #-} {-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE TemplateHaskell        #-} -- | This module define all the types used in the definition -- of a svg scene. --@@ -47,8 +48,22 @@       -- * Drawing attributes     , DrawAttributes( .. )     , HasDrawAttributes( .. )-    , WithDrawAttributes( .. ) +      -- * Filters+    , FilterElement(..)+    , FilterAttributes(..)+    , HasFilterAttributes(..)+    , FilterSource(..)+    , ColorMatrixType(..)+    , HasColorMatrix(..)+    , ColorMatrix(..)+    , HasComposite(..)+    , Composite(..)+    , CompositeOperator(..)+    , EdgeMode(..)+    , HasGaussianBlur(..)+    , GaussianBlur(..)+       -- * SVG drawing primitives       -- ** Rectangle     , Rectangle( .. )@@ -112,6 +127,10 @@     , Definitions( .. )     , groupOfDefinitions +    -- ** Filter+    , Filter( .. )+    , groupOfFilter+       -- * Text related types       -- ** Text     , Text( .. )@@ -193,6 +212,7 @@ import           Codec.Picture             (PixelRGBA8 (..)) import           Control.Lens              (Lens, Lens', lens, view, (&), (.~),                                             (^.))+import           Control.Lens.TH import qualified Data.Foldable             as F import           Data.Function             (on) import           Data.List                 (inits)@@ -394,12 +414,6 @@ 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@@ -449,6 +463,32 @@   | Ref String -- ^ Equivalent to `url()` attribute.   deriving (Eq, Show) +data FilterSource+  = SourceGraphic+  | SourceAlpha+  | BackgroundImage+  | BackgroundAlpha+  | FillPaint+  | StrokePaint+  | SourceRef String+  deriving (Eq, Show)++data FilterAttributes = FilterAttributes+  { _filterHeight :: !(Last Number)+  , _filterResult :: !(Maybe String)+  , _filterWidth  :: !(Last Number)+  , _filterX      :: !(Last Number)+  , _filterY      :: !(Last Number)+  } deriving (Eq, Show)++instance WithDefaultSvg FilterAttributes where+  defaultSvg = FilterAttributes+    { _filterHeight = Last Nothing+    , _filterResult = Nothing+    , _filterWidth  = Last Nothing+    , _filterX      = Last Nothing+    , _filterY      = Last Nothing }+ -- | This type define how to draw any primitives, -- which color to use, how to stroke the primitives -- and the potential transformations to use.@@ -523,9 +563,11 @@       -- | Define the marker used for the end of the line.       -- Correspond to the `marker-end` attribute.     , _markerEnd        :: !(Last ElementRef)+    , _filterRef        :: !(Last ElementRef)     }     deriving (Eq, Show) +makeClassy ''DrawAttributes  -- | This primitive describe an unclosed suite of -- segments. Correspond to the `<polyline>` tag.@@ -567,8 +609,8 @@   polyLinePoints f p =     fmap (\y -> p { _polyLinePoints = y }) (f $ _polyLinePoints p) -instance WithDrawAttributes PolyLine where-    drawAttr = polyLineDrawAttributes+instance HasDrawAttributes PolyLine where+    drawAttributes = polyLineDrawAttributes  -- | Primitive decriving polygon composed -- of segements. Correspond to the `<polygon>`@@ -602,8 +644,8 @@   polygonPoints f p =     fmap (\y -> p { _polygonPoints = y }) (f $ _polygonPoints p) -instance WithDrawAttributes Polygon where-    drawAttr = polygonDrawAttributes+instance HasDrawAttributes Polygon where+    drawAttributes = polygonDrawAttributes  instance WithDefaultSvg Polygon where   defaultSvg = Polygon@@ -651,8 +693,8 @@   linePoint2 f l =       fmap (\y -> l { _linePoint2 = y }) (f (_linePoint2 l)) -instance WithDrawAttributes Line where-    drawAttr = lineDrawAttributes+instance HasDrawAttributes Line where+    drawAttributes = lineDrawAttributes  instance WithDefaultSvg Line where   defaultSvg = Line@@ -725,8 +767,8 @@   rectWidth f attr =     fmap (\y -> attr { _rectWidth = y }) (f $ _rectWidth attr) -instance WithDrawAttributes Rectangle where-    drawAttr = rectDrawAttributes+instance HasDrawAttributes Rectangle where+    drawAttributes = rectDrawAttributes  instance WithDefaultSvg Rectangle where   defaultSvg = Rectangle@@ -768,8 +810,8 @@   pathDrawAttributes f attr =     fmap (\y -> attr { _pathDrawAttributes = y }) (f $ _pathDrawAttributes attr) -instance WithDrawAttributes Path where-  drawAttr = pathDrawAttributes+instance HasDrawAttributes Path where+  drawAttributes = pathDrawAttributes  instance WithDefaultSvg Path where   defaultSvg = Path@@ -830,8 +872,8 @@   groupViewBox f attr =     fmap (\y -> attr { _groupViewBox = y }) (f $ _groupViewBox attr) -instance WithDrawAttributes (Group a) where-    drawAttr = groupDrawAttributes+instance HasDrawAttributes (Group a) where+  drawAttributes = groupDrawAttributes  instance WithDefaultSvg (Group a) where   defaultSvg = Group@@ -853,8 +895,8 @@ {-# INLINE groupOfSymbol #-} groupOfSymbol f = fmap Symbol . f . _groupOfSymbol -instance WithDrawAttributes (Symbol a) where-  drawAttr = groupOfSymbol . drawAttr+instance HasDrawAttributes (Symbol a) where+  drawAttributes = groupOfSymbol . drawAttributes  instance WithDefaultSvg (Symbol a) where   defaultSvg = Symbol defaultSvg@@ -871,12 +913,27 @@ {-# INLINE groupOfDefinitions #-} groupOfDefinitions f = fmap Definitions . f . _groupOfDefinitions -instance WithDrawAttributes (Definitions a) where-  drawAttr = groupOfDefinitions . drawAttr+instance HasDrawAttributes (Definitions a) where+  drawAttributes = groupOfDefinitions . drawAttributes  instance WithDefaultSvg (Definitions a) where   defaultSvg = Definitions defaultSvg +-- | Define the `<filter>` tag.+newtype Filter a =+    Filter { _groupOfFilter :: Group a }+  deriving (Eq, Show)++-- | Lenses associated with the Definitions type.+groupOfFilter :: Lens (Filter s) (Filter t) (Group s) (Group t)+groupOfFilter f = fmap Filter . f . _groupOfFilter++instance HasDrawAttributes (Filter a) where+  drawAttributes = groupOfFilter . drawAttributes++instance WithDefaultSvg (Filter a) where+  defaultSvg = Filter defaultSvg+ -- | Define a `<circle>`. data Circle = Circle   { -- | Drawing attributes of the circle.@@ -918,8 +975,8 @@   circleRadius f attr =     fmap (\y -> attr { _circleRadius = y }) (f $ _circleRadius attr) -instance WithDrawAttributes Circle where-    drawAttr = circleDrawAttributes+instance HasDrawAttributes Circle where+    drawAttributes = circleDrawAttributes  instance WithDefaultSvg Circle where   defaultSvg = Circle@@ -976,8 +1033,8 @@   ellipseYRadius f attr =     fmap (\y -> attr { _ellipseYRadius = y }) (f $ _ellipseYRadius attr) -instance WithDrawAttributes Ellipse where-  drawAttr = ellipseDrawAttributes+instance HasDrawAttributes Ellipse where+  drawAttributes = ellipseDrawAttributes  instance WithDefaultSvg Ellipse where   defaultSvg = Ellipse@@ -1158,9 +1215,10 @@   meshGradientY f attr =     fmap (\y -> attr { _meshGradientY = y }) (f $ _meshGradientY attr) -instance WithDrawAttributes MeshGradient where-  drawAttr = meshGradientDrawAttributes +instance HasDrawAttributes MeshGradient where+  drawAttributes = meshGradientDrawAttributes+ instance WithDefaultSvg MeshGradient where   defaultSvg = MeshGradient     { _meshGradientDrawAttributes = mempty@@ -1234,9 +1292,10 @@   imageWidth f attr =     fmap (\y -> attr { _imageWidth = y }) (f $ _imageWidth attr) -instance WithDrawAttributes Image where-  drawAttr = imageDrawAttributes +instance HasDrawAttributes Image where+  drawAttributes = imageDrawAttributes+ instance WithDefaultSvg Image where   defaultSvg = Image     { _imageDrawAttributes = mempty@@ -1307,8 +1366,8 @@   useWidth f attr =     fmap (\y -> attr { _useWidth = y }) (f $ _useWidth attr) -instance WithDrawAttributes Use where-  drawAttr = useDrawAttributes+instance HasDrawAttributes Use where+  drawAttributes = useDrawAttributes  instance WithDefaultSvg Use where   defaultSvg = Use@@ -1464,47 +1523,11 @@   , _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)+makeClassy ''TextPath  instance WithDefaultSvg TextPath where   defaultSvg = TextPath@@ -1512,7 +1535,6 @@     , _textPathName        = mempty     , _textPathMethod      = TextPathAlign     , _textPathSpacing     = TextPathSpacingExact-    , _textPathData        = []     }  -- | Define the possible values of the `lengthAdjust`@@ -1562,8 +1584,8 @@                     }         } -instance WithDrawAttributes Text where-  drawAttr = textRoot . spanDrawAttributes+instance HasDrawAttributes Text where+  drawAttributes = textRoot . spanDrawAttributes  instance WithDefaultSvg Text where   defaultSvg = Text@@ -1580,6 +1602,7 @@     | GroupTree     !(Group Tree)     | SymbolTree    !(Symbol Tree)     | DefinitionTree !(Definitions Tree)+    | FilterTree    !(Filter FilterElement)     | PathTree      !Path     | CircleTree    !Circle     | PolyLineTree  !PolyLine@@ -1598,6 +1621,118 @@     | ClipPathTree  !ClipPath     deriving (Eq, Show) +data FilterElement+  = FEBlend+  | FEColorMatrix ColorMatrix+  | FEComponentTransfer+  | FEComposite Composite+  | FEConvolveMatrix+  | FEDiffuseLighting+  | FEDisplacementMap+  | FEDropShadow+  | FEFlood+  | FEFuncA+  | FEFuncB+  | FEFuncG+  | FEFuncR+  | FEGaussianBlur GaussianBlur+  | FEImage+  | FEMerge+  | FEMergeNode+  | FEMorphology+  | FEOffset+  | FESpecularLighting+  | FETile+  | FETurbulence+  | FENone+  deriving (Eq,Show)++instance WithDefaultSvg FilterElement where+  defaultSvg = FENone++data ColorMatrixType+  = Matrix+  | Saturate+  | HueRotate+  | LuminanceToAlpha+  deriving (Eq,Show)++data ColorMatrix = ColorMatrix+  { _colorMatrixDrawAttributes :: !DrawAttributes+  , _colorMatrixFilterAttr     :: !FilterAttributes+  , _colorMatrixIn             :: !(Last FilterSource)+  , _colorMatrixType           :: !ColorMatrixType+  , _colorMatrixValues         :: !String+  } deriving (Eq,Show)++instance WithDefaultSvg ColorMatrix where+  defaultSvg = ColorMatrix+    { _colorMatrixDrawAttributes = defaultSvg+    , _colorMatrixFilterAttr     = defaultSvg+    , _colorMatrixIn             = Last Nothing+    , _colorMatrixType           = Matrix+    , _colorMatrixValues         = ""+    }++data CompositeOperator+  = CompositeOver -- this is default+  | CompositeIn+  | CompositeOut+  | CompositeAtop+  | CompositeXor+  | CompositeArithmetic+  deriving (Eq, Show)++data Composite = Composite+  { _compositeDrawAttributes :: DrawAttributes+  , _compositeFilterAttr     :: !FilterAttributes+  , _compositeIn             :: Last FilterSource+  , _compositeIn2            :: Last FilterSource+  , _compositeOperator       :: CompositeOperator+  , _compositeK1             :: Number+  , _compositeK2             :: Number+  , _compositeK3             :: Number+  , _compositeK4             :: Number+  } deriving (Eq, Show)++instance WithDefaultSvg Composite where+  defaultSvg = Composite+    { _compositeDrawAttributes = defaultSvg+    , _compositeFilterAttr     = defaultSvg+    , _compositeIn             = Last Nothing+    , _compositeIn2            = Last Nothing+    , _compositeOperator       = CompositeOver+    , _compositeK1             = Num 0+    , _compositeK2             = Num 0+    , _compositeK3             = Num 0+    , _compositeK4             = Num 0+    }++data EdgeMode+  = EdgeDuplicate+  | EdgeWrap+  | EdgeNone+  deriving (Eq,Show)++data GaussianBlur = GaussianBlur+  { _gaussianBlurDrawAttributes :: DrawAttributes+  , _gaussianBlurFilterAttr     :: !FilterAttributes+  , _gaussianBlurIn             :: Last FilterSource+  , _gaussianBlurStdDeviationX  :: Number+  , _gaussianBlurStdDeviationY  :: Last Number+  , _gaussianBlurEdgeMode       :: EdgeMode+  } deriving (Eq,Show)++instance WithDefaultSvg GaussianBlur where+  defaultSvg = GaussianBlur+    { _gaussianBlurDrawAttributes = defaultSvg+    , _gaussianBlurFilterAttr     = defaultSvg+    , _gaussianBlurIn             = Last Nothing+    , _gaussianBlurStdDeviationX      = Num 0+    , _gaussianBlurStdDeviationY      = Last Nothing+    , _gaussianBlurEdgeMode           = EdgeDuplicate+    }+ -- | Define the orientation, associated to the -- `orient` attribute on the Marker data MarkerOrientation@@ -1715,8 +1850,8 @@   markerWidth f attr =     fmap (\y -> attr { _markerWidth = y }) (f $ _markerWidth attr) -instance WithDrawAttributes Marker where-    drawAttr = markerDrawAttributes+instance HasDrawAttributes Marker where+  drawAttributes = markerDrawAttributes  instance WithDefaultSvg Marker where   defaultSvg = Marker@@ -1752,6 +1887,10 @@   dig prev e@(SymbolTree g) =       f . appNode prev . SymbolTree . Symbol .             zipGroup (appNode prev e) $ _groupOfSymbol g+  dig prev e@(DefinitionTree g) =+      f . appNode prev . DefinitionTree . Definitions .+            zipGroup (appNode prev e) $ _groupOfDefinitions g+  dig prev e@(FilterTree _) = f $ appNode prev e   dig prev e@(PathTree _) = f $ appNode prev e   dig prev e@(CircleTree _) = f $ appNode prev e   dig prev e@(PolyLineTree _) = f $ appNode prev e@@ -1762,7 +1901,6 @@   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@@ -1782,35 +1920,32 @@ 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+    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+    MeshGradientTree _   -> f acc e+    PatternTree _        -> f acc e+    MarkerTree _         -> f acc e+    MaskTree _           -> f acc e+    ClipPathTree _       -> f acc e+    DefinitionTree g     -> foldGroup (_groupOfDefinitions g)+    FilterTree _         -> f acc e+    GroupTree g          -> foldGroup g+    SymbolTree s         -> foldGroup (_groupOfSymbol s)+    where+      foldGroup g =+        let subAcc = F.foldl' go acc $ _groupChildren g in+        f subAcc e  -- | Helper function mapping every tree element. mapTree :: (Tree -> Tree) -> Tree -> Tree@@ -1822,6 +1957,7 @@       f . SymbolTree . Symbol . mapGroup $ _groupOfSymbol g   go (DefinitionTree defs) =     f . DefinitionTree . Definitions . mapGroup $ _groupOfDefinitions defs+  go e@(FilterTree _) = f e   go e@(PathTree _) = f e   go e@(CircleTree _) = f e   go e@(PolyLineTree _) = f e@@ -1852,6 +1988,7 @@    GroupTree _          -> "g"    SymbolTree _         -> "symbol"    DefinitionTree _     -> "defs"+   FilterTree _         -> "filter"    PathTree _           -> "path"    CircleTree _         -> "circle"    PolyLineTree _       -> "polyline"@@ -1872,54 +2009,57 @@ 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+  UseTree e _          -> e ^. drawAttributes+  GroupTree e          -> e ^. drawAttributes+  SymbolTree e         -> e ^. drawAttributes+  DefinitionTree e     -> e ^. drawAttributes+  FilterTree e         -> e ^. drawAttributes+  PathTree e           -> e ^. drawAttributes+  CircleTree e         -> e ^. drawAttributes+  PolyLineTree e       -> e ^. drawAttributes+  PolygonTree e        -> e ^. drawAttributes+  EllipseTree e        -> e ^. drawAttributes+  LineTree e           -> e ^. drawAttributes+  RectangleTree e      -> e ^. drawAttributes+  TextTree _ e         -> e ^. drawAttributes+  ImageTree e          -> e ^. drawAttributes+  LinearGradientTree e -> e ^. drawAttributes+  RadialGradientTree e -> e ^. drawAttributes+  MeshGradientTree e   -> e ^. drawAttributes+  PatternTree e        -> e ^. drawAttributes+  MarkerTree e         -> e ^. drawAttributes+  MaskTree e           -> e ^. drawAttributes+  ClipPathTree e       -> e ^. drawAttributes  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+  UseTree e m          -> UseTree (e & drawAttributes .~ attr) m+  GroupTree e          -> GroupTree $ e & drawAttributes .~ attr+  SymbolTree e         -> SymbolTree $ e & drawAttributes .~ attr+  DefinitionTree e     -> DefinitionTree e & drawAttributes .~ attr+  FilterTree e         -> FilterTree $ e & drawAttributes .~ attr+  PathTree e           -> PathTree $ e & drawAttributes .~ attr+  CircleTree e         -> CircleTree $ e & drawAttributes .~ attr+  PolyLineTree e       -> PolyLineTree $ e & drawAttributes .~ attr+  PolygonTree e        -> PolygonTree $ e & drawAttributes .~ attr+  EllipseTree e        -> EllipseTree $ e & drawAttributes .~ attr+  LineTree e           -> LineTree $ e & drawAttributes .~ attr+  RectangleTree e      -> RectangleTree $ e & drawAttributes .~ attr+  TextTree a e         -> TextTree a $ e & drawAttributes .~ attr+  ImageTree e          -> ImageTree $ e & drawAttributes .~ attr+  LinearGradientTree e -> LinearGradientTree $ e & drawAttributes .~ attr+  RadialGradientTree e -> RadialGradientTree $ e & drawAttributes .~ attr+  MeshGradientTree e   -> MeshGradientTree $ e & drawAttributes .~ attr+  PatternTree e        -> PatternTree $ e & drawAttributes .~ attr+  MarkerTree e         -> MarkerTree $ e & drawAttributes .~ attr+  MaskTree e           -> MaskTree $ e & drawAttributes .~ attr+  ClipPathTree e       -> ClipPathTree $ e & drawAttributes .~ attr -instance WithDrawAttributes Tree where-    drawAttr = lens drawAttrOfTree setDrawAttrOfTree +instance HasDrawAttributes Tree where+  drawAttributes = lens drawAttrOfTree setDrawAttrOfTree+ instance WithDefaultSvg Tree where     defaultSvg = None @@ -2004,9 +2144,10 @@   linearGradientUnits f attr =     fmap (\y -> attr { _linearGradientUnits = y }) (f $ _linearGradientUnits attr) -instance WithDrawAttributes LinearGradient where-  drawAttr = linearGradientDrawAttributes +instance HasDrawAttributes LinearGradient where+  drawAttributes = linearGradientDrawAttributes+ instance WithDefaultSvg LinearGradient where   defaultSvg = LinearGradient     { _linearGradientDrawAttributes = mempty@@ -2110,9 +2251,10 @@   radialGradientUnits f attr =     fmap (\y -> attr { _radialGradientUnits = y }) (f $ _radialGradientUnits attr) -instance WithDrawAttributes RadialGradient where-  drawAttr = radialGradientDrawAttributes +instance HasDrawAttributes RadialGradient where+  drawAttributes = radialGradientDrawAttributes+ instance WithDefaultSvg RadialGradient where   defaultSvg = RadialGradient     { _radialGradientDrawAttributes = mempty@@ -2195,9 +2337,10 @@   maskWidth f attr =     fmap (\y -> attr { _maskWidth = y }) (f $ _maskWidth attr) -instance WithDrawAttributes Mask where-  drawAttr = maskDrawAttributes +instance HasDrawAttributes Mask where+  drawAttributes = maskDrawAttributes+ instance WithDefaultSvg Mask where   defaultSvg = Mask     { _maskDrawAttributes = mempty@@ -2244,9 +2387,10 @@   clipPathUnits f attr =     fmap (\y -> attr { _clipPathUnits = y }) (f $ _clipPathUnits attr) -instance WithDrawAttributes ClipPath where-  drawAttr = clipPathDrawAttributes +instance HasDrawAttributes ClipPath where+  drawAttributes = clipPathDrawAttributes+ instance WithDefaultSvg ClipPath where   defaultSvg = ClipPath     { _clipPathDrawAttributes = mempty@@ -2354,8 +2498,8 @@   patternWidth f attr =     fmap (\y -> attr { _patternWidth = y }) (f $ _patternWidth attr) -instance WithDrawAttributes Pattern where-    drawAttr = patternDrawAttributes+instance HasDrawAttributes Pattern where+  drawAttributes = patternDrawAttributes  instance WithDefaultSvg Pattern where   defaultSvg = Pattern@@ -2393,80 +2537,13 @@     , _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)+-- | Lenses associated to a SVG document.+makeClassy ''Document  -- | Calculate the document size in function of the -- different available attributes in the document.@@ -2522,6 +2599,7 @@         , _markerStart = (mappend `on` _markerStart) a b         , _markerMid = (mappend `on` _markerMid) a b         , _markerEnd = (mappend `on` _markerEnd) a b+        , _filterRef = (mappend `on` _filterRef) a b         }       where         opacityMappend Nothing Nothing    = Nothing@@ -2558,6 +2636,7 @@         , _markerStart      = Last Nothing         , _markerMid        = Last Nothing         , _markerEnd        = Last Nothing+        , _filterRef        = Last Nothing         }  instance WithDefaultSvg DrawAttributes where@@ -2565,8 +2644,8 @@  instance CssMatcheable Tree where   cssAttribOf _ _ = Nothing-  cssClassOf = view (drawAttr . attrClass)-  cssIdOf = fmap T.pack . view (drawAttr . attrId)+  cssClassOf = view (drawAttributes . attrClass)+  cssIdOf = fmap T.pack . view (drawAttributes . attrId)   cssNameOf = nameOfTree  --------------------------------------------------------------------------@@ -2603,185 +2682,149 @@   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+-- makeClassy ''FilterAttributes+-- | Lenses for the FilterAttributes type.+class HasFilterAttributes c_asYk where+  filterAttributes :: Lens' c_asYk FilterAttributes+  filterHeight :: Lens' c_asYk (Last Number)+  {-# INLINE filterHeight #-}+  filterResult :: Lens' c_asYk (Maybe String)+  {-# INLINE filterResult #-}+  filterWidth :: Lens' c_asYk (Last Number)+  {-# INLINE filterWidth #-}+  filterX :: Lens' c_asYk (Last Number)+  {-# INLINE filterX #-}+  filterY :: Lens' c_asYk (Last Number)+  {-# INLINE filterY #-}+  filterHeight = ((.) filterAttributes) filterHeight+  filterResult = ((.) filterAttributes) filterResult+  filterWidth = ((.) filterAttributes) filterWidth+  filterX = ((.) filterAttributes) filterX+  filterY = ((.) filterAttributes) filterY+instance HasFilterAttributes FilterAttributes where+  {-# INLINE filterHeight #-}+  {-# INLINE filterResult #-}+  {-# INLINE filterWidth #-}+  {-# INLINE filterX #-}+  {-# INLINE filterY #-}+  filterAttributes = id+  filterHeight+    f_asYl+    (FilterAttributes x1_asYm x2_asYn x3_asYo x4_asYp x5_asYq)+    = (fmap+         (\ y1_asYr+            -> ((((FilterAttributes y1_asYr) x2_asYn) x3_asYo) x4_asYp)+                 x5_asYq))+        (f_asYl x1_asYm)+  filterResult+    f_asYs+    (FilterAttributes x1_asYt x2_asYu x3_asYv x4_asYw x5_asYx)+    = (fmap+         (\ y1_asYy+            -> ((((FilterAttributes x1_asYt) y1_asYy) x3_asYv) x4_asYw)+                 x5_asYx))+        (f_asYs x2_asYu)+  filterWidth+    f_asYz+    (FilterAttributes x1_asYA x2_asYB x3_asYC x4_asYD x5_asYE)+    = (fmap+         (\ y1_asYF+            -> ((((FilterAttributes x1_asYA) x2_asYB) y1_asYF) x4_asYD)+                 x5_asYE))+        (f_asYz x3_asYC)+  filterX+    f_asYG+    (FilterAttributes x1_asYH x2_asYI x3_asYJ x4_asYK x5_asYL)+    = (fmap+         (\ y1_asYM+            -> ((((FilterAttributes x1_asYH) x2_asYI) x3_asYJ) y1_asYM)+                 x5_asYL))+        (f_asYG x4_asYK)+  filterY+    f_asYN+    (FilterAttributes x1_asYO x2_asYP x3_asYQ x4_asYR x5_asYS)+    = (fmap+         (\ y1_asYT+            -> ((((FilterAttributes x1_asYO) x2_asYP) x3_asYQ) x4_asYR)+                 y1_asYT))+        (f_asYN x5_asYS) -  attrId :: Lens' a (Maybe String)-  {-# INLINE attrId #-}-  attrId = drawAttributes . attrId -  clipPathRef :: Lens' a (Last ElementRef)-  {-# INLINE clipPathRef #-}-  clipPathRef = drawAttributes . clipPathRef+-- | Lenses for the DrawAttributes type.+-- makeClassy ''DrawAttributes -  clipRule :: Lens' a (Last FillRule)-  {-# INLINE clipRule #-}-  clipRule = drawAttributes . clipRule -  fillColor :: Lens' a (Last Texture)-  {-# INLINE fillColor #-}-  fillColor = drawAttributes . fillColor+makeClassy ''Composite+makeClassy ''ColorMatrix+makeClassy ''GaussianBlur -  fillOpacity :: Lens' a (Maybe Float)-  {-# INLINE fillOpacity #-}-  fillOpacity = drawAttributes . fillOpacity+instance HasDrawAttributes Composite where+    drawAttributes = compositeDrawAttributes -  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+instance HasDrawAttributes ColorMatrix where+    drawAttributes = colorMatrixDrawAttributes -  strokeWidth :: Lens' a (Last Number)-  {-# INLINE strokeWidth #-}-  strokeWidth = drawAttributes . strokeWidth+instance HasDrawAttributes GaussianBlur where+    drawAttributes = gaussianBlurDrawAttributes -  textAnchor :: Lens' a (Last TextAnchor)-  {-# INLINE textAnchor #-}-  textAnchor = drawAttributes . textAnchor+instance HasFilterAttributes Composite where+  filterAttributes = compositeFilterAttr -  transform :: Lens' a (Maybe [Transformation])-  {-# INLINE transform #-}-  transform = drawAttributes . transform+instance HasFilterAttributes ColorMatrix where+  filterAttributes = colorMatrixFilterAttr -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+instance HasFilterAttributes GaussianBlur where+  filterAttributes = gaussianBlurFilterAttr -  {-# 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)+instance HasFilterAttributes FilterElement where+  filterAttributes = lens getter setter+    where+      getter fe = case fe of+          FEBlend             -> defaultSvg+          FEColorMatrix m     -> m ^. filterAttributes+          FEComponentTransfer -> defaultSvg+          FEComposite c       -> c ^. filterAttributes+          FEConvolveMatrix    -> defaultSvg+          FEDiffuseLighting   -> defaultSvg+          FEDisplacementMap   -> defaultSvg+          FEDropShadow        -> defaultSvg+          FEFlood             -> defaultSvg+          FEFuncA             -> defaultSvg+          FEFuncB             -> defaultSvg+          FEFuncG             -> defaultSvg+          FEFuncR             -> defaultSvg+          FEGaussianBlur g    -> g ^. filterAttributes+          FEImage             -> defaultSvg+          FEMerge             -> defaultSvg+          FEMergeNode         -> defaultSvg+          FEMorphology        -> defaultSvg+          FEOffset            -> defaultSvg+          FESpecularLighting  -> defaultSvg+          FETile              -> defaultSvg+          FETurbulence        -> defaultSvg+          FENone              -> defaultSvg+      setter fe attr = case fe of+        FEBlend             -> fe+        FEColorMatrix m     -> FEColorMatrix $ m & filterAttributes .~ attr+        FEComponentTransfer -> fe+        FEComposite c       -> FEComposite $ c & filterAttributes .~ attr+        FEConvolveMatrix    -> fe+        FEDiffuseLighting   -> fe+        FEDisplacementMap   -> fe+        FEDropShadow        -> fe+        FEFlood             -> fe+        FEFuncA             -> fe+        FEFuncB             -> fe+        FEFuncG             -> fe+        FEFuncR             -> fe+        FEGaussianBlur g    -> FEGaussianBlur $ g & filterAttributes .~ attr+        FEImage             -> fe+        FEMerge             -> fe+        FEMergeNode         -> fe+        FEMorphology        -> fe+        FEOffset            -> fe+        FESpecularLighting  -> fe+        FETile              -> fe+        FETurbulence        -> fe+        FENone              -> fe

@@ -30,26 +30,22 @@ 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           Control.Lens.Unsound+import           Data.Attoparsec.Text         (Parser, 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)+                                               numberList, styleString) import           Graphics.SvgTree.CssTypes    (CssDeclaration (..),-                                               CssElement (..), CssRule,-                                               tserialize)+                                               CssElement (..)) 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.XML.Light.Proc          (elChildren, findAttrBy)  import           Text.Printf                  (printf) @@ -341,6 +337,78 @@     TextPathSpacingAuto  -> "auto"     TextPathSpacingExact -> "exact" +instance ParseableAttribute CompositeOperator where+  aparse s = case s of+    "over"       -> Just CompositeOver+    "in"         -> Just CompositeIn+    "out"        -> Just CompositeOut+    "atop"       -> Just CompositeAtop+    "xor"        -> Just CompositeXor+    "arithmetic" -> Just CompositeArithmetic+    _            -> Nothing++  aserialize v = Just $ case v of+    CompositeOver       -> "over"+    CompositeIn         -> "in"+    CompositeOut        -> "out"+    CompositeAtop       -> "atop"+    CompositeXor        -> "xor"+    CompositeArithmetic -> "arithmetic"++instance ParseableAttribute FilterSource where+  aparse s = Just $ case s of+    "SourceGraphic"   -> SourceGraphic+    "SourceAlpha"     -> SourceAlpha+    "BackgroundImage" -> BackgroundImage+    "BackgroundAlpha" -> BackgroundAlpha+    "FillPaint"       -> FillPaint+    "StrokePaint"     -> StrokePaint+    _                 -> SourceRef s++  aserialize v = Just $ case v of+    SourceGraphic   -> "SourceGraphic"+    SourceAlpha     -> "SourceAlpha"+    BackgroundImage -> "BackgroundImage"+    BackgroundAlpha -> "BackgroundAlpha"+    FillPaint       -> "FillPaint"+    StrokePaint     -> "StrokePaint"+    SourceRef s     -> s++instance ParseableAttribute ColorMatrixType where+  aparse s = case s of+    "matrix"           -> Just Matrix+    "saturate"         -> Just Saturate+    "hueRotate"        -> Just HueRotate+    "luminanceToAlpha" -> Just LuminanceToAlpha+    _                  -> Nothing++  aserialize v = Just $ case v of+    Matrix           -> "matrix"+    Saturate         -> "saturate"+    HueRotate        -> "hueRotate"+    LuminanceToAlpha -> "luminanceToAlpha"++instance ParseableAttribute EdgeMode where+  aparse s = case s of+    "duplicate" -> Just EdgeDuplicate+    "wrap"      -> Just EdgeWrap+    "none"      -> Just EdgeNone+    _           -> Nothing++  aserialize v = Just $ case v of+    EdgeDuplicate -> "duplicate"+    EdgeWrap      -> "wrap"+    EdgeNone      -> "none"++instance ParseableAttribute (Number, Last Number) where+  aparse s = case aparse s of+    Just [x]   -> Just (x, Last Nothing)+    Just [x,y] -> Just (x, Last (Just y))+    _          -> Nothing++  aserialize (x, Last Nothing)  = aserialize [x]+  aserialize (x, Last (Just y)) = aserialize [x, y]+ parse :: Parser a -> String -> Maybe a parse p str = case parseOnly p (T.pack str) of   Left _  -> Nothing@@ -358,14 +426,14 @@           Nothing -> value           Just v  -> _attributeUpdater updater value v -xmlUnparse :: (XMLUpdatable a) => X.Element -> a+xmlUnparse :: (WithDefaultSvg a, XMLUpdatable a) => X.Element -> a xmlUnparse = xmlUpdate defaultSvg  xmlUnparseWithDrawAttr-    :: (XMLUpdatable a, WithDrawAttributes a)+    :: (WithDefaultSvg a, XMLUpdatable a, HasDrawAttributes a)     => X.Element -> a xmlUnparseWithDrawAttr e =-    xmlUnparse e & drawAttr .~ xmlUnparse e+    xmlUnparse e & drawAttributes .~ xmlUnparse e  data SvgAttributeLens t = SvgAttributeLens   { _attributeName       :: String@@ -373,7 +441,7 @@   , _attributeSerializer :: t -> Maybe String   } -class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where+class XMLUpdatable treeNode where   xmlTagName :: treeNode -> String   attributes :: [SvgAttributeLens treeNode] @@ -409,11 +477,11 @@ mergeAttributes thisXml otherXml =     thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml } -genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode)+genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, HasDrawAttributes treeNode)                              => treeNode -> Maybe X.Element genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where   thisXml = genericSerializeNode node-  drawAttrNode = genericSerializeNode $ node ^. drawAttr+  drawAttrNode = genericSerializeNode $ node ^. drawAttributes  type CssUpdater a =     a -> [[CssElement]] -> a@@ -586,6 +654,7 @@   ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd)   ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart)   ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid)+  ,("filter" `parseIn` filterRef, cssNullSetter)   ]   where     commaSeparate =@@ -758,6 +827,7 @@     GroupTree g -> serializeTreeNode g     SymbolTree s -> serializeTreeNode s     DefinitionTree d -> serializeTreeNode d+    FilterTree g -> serializeTreeNode g     PathTree p -> serializeTreeNode p     CircleTree c -> serializeTreeNode c     PolyLineTree p -> serializeTreeNode p@@ -812,7 +882,51 @@      ,"preserveAspectRatio" `parseIn` (groupOfDefinitions . groupAspectRatio)      ] +instance XMLUpdatable (Filter FilterElement) where+  xmlTagName _ = "filter"+  serializeTreeNode node =+     updateWithAccessor (_groupChildren . _groupOfFilter) node $+        genericSerializeWithDrawAttr node+  attributes = [] +instance XMLUpdatable FilterElement where+  xmlTagName _ = "FilterElement"+  serializeTreeNode fe = flip mergeAttributes <$> (genericSerializeNode fe) <*>+    case fe of+      FEColorMatrix m  -> serializeTreeNode m+      FEComposite c    -> serializeTreeNode c+      FEGaussianBlur b -> serializeTreeNode b+  attributes =+    [ "result" `parseIn` (filterAttributes . filterResult)]++instance XMLUpdatable ColorMatrix where+  xmlTagName _ = "feColorMatrix"+  serializeTreeNode = genericSerializeWithDrawAttr+  attributes =+    [ "in" `parseIn` colorMatrixIn+    , "type" `parseIn` colorMatrixType+    , "values" `parseIn` colorMatrixValues ]++instance XMLUpdatable Composite where+  xmlTagName _ = "feComposite"+  serializeTreeNode = genericSerializeWithDrawAttr+  attributes =+    [ "in" `parseIn` compositeIn+    , "in2" `parseIn` compositeIn2+    , "operator" `parseIn` compositeOperator+    , "k1" `parseIn` compositeK1+    , "k2" `parseIn` compositeK2+    , "k3" `parseIn` compositeK3+    , "k4" `parseIn` compositeK4 ]++instance XMLUpdatable GaussianBlur where+  xmlTagName _ = "feGaussianBlur"+  serializeTreeNode = genericSerializeWithDrawAttr+  attributes =+    [ "in" `parseIn` gaussianBlurIn+    , "stdDeviation" `parseIn` lensProduct gaussianBlurStdDeviationX gaussianBlurStdDeviationY+    , "edgeMode" `parseIn` gaussianBlurEdgeMode ]+ instance XMLUpdatable RadialGradient where   xmlTagName _ = "radialGradient"   serializeTreeNode node =@@ -1025,14 +1139,6 @@         ]  -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@@ -1049,78 +1155,41 @@   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+unparseFE :: X.Element -> FilterElement+unparseFE _ = FENone++unparse :: X.Element -> Tree+unparse e@(nodeName -> "pattern") =+  PatternTree $ xmlUnparse e & patternElements .~ map unparse (elChildren e)+unparse e@(nodeName -> "marker") =+  MarkerTree $ xmlUnparseWithDrawAttr e & markerElements .~ map unparse (elChildren e)+unparse e@(nodeName -> "mask") =+  MaskTree $ xmlUnparseWithDrawAttr e & maskContent .~ map unparse (elChildren e)+unparse e@(nodeName -> "clipPath") =+  ClipPathTree $ xmlUnparseWithDrawAttr e & clipPathContent .~ map unparse (elChildren e)+unparse (nodeName -> "style") = None -- XXX: Create a style node?+unparse e@(nodeName -> "defs") =+  DefinitionTree . Definitions $ groupNode & groupChildren .~ map unparse (elChildren e)   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+unparse e@(nodeName -> "filter") =+  FilterTree . Filter $ groupNode & groupChildren .~ map unparseFE (elChildren e)   where+    groupNode :: Group FilterElement+    groupNode = undefined -- xmlUnparseWithDrawAttr e+unparse e@(nodeName -> "symbol") =+  SymbolTree . Symbol $ groupNode & groupChildren .~ map unparse (elChildren e)+  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+unparse e@(nodeName -> "g") =+  GroupTree $ xmlUnparseWithDrawAttr e & groupChildren .~ map unparse (elChildren e)+unparse e@(nodeName -> "text") =+  TextTree tPath $ 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@@ -1128,24 +1197,24 @@            }  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+    "image"    -> ImageTree parsed+    "ellipse"  -> EllipseTree parsed+    "rect"     -> RectangleTree parsed+    "polyline" -> PolyLineTree parsed+    "polygon"  -> PolygonTree parsed+    "circle"   -> CircleTree parsed+    "line"     -> LineTree parsed+    "path"     -> PathTree parsed     "linearGradient" ->-      pure $ LinearGradientTree $ parsed & linearGradientStops .~ parseGradientStops e+      LinearGradientTree $ parsed & linearGradientStops .~ parseGradientStops e     "radialGradient" ->-      pure $ RadialGradientTree $ parsed & radialGradientStops .~ parseGradientStops e+      RadialGradientTree $ parsed & radialGradientStops .~ parseGradientStops e     "meshgradient" ->-      pure $ MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e-    "use" -> pure $ UseTree parsed Nothing-    _ -> pure None+      MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e+    "use" -> UseTree parsed Nothing+    _ -> None   where-    parsed :: (XMLUpdatable a, WithDrawAttributes a) => a+    parsed :: (WithDefaultSvg a, XMLUpdatable a, HasDrawAttributes a) => a     parsed = xmlUnparseWithDrawAttr e  unparseDocument :: FilePath -> X.Element -> Maybe Document@@ -1157,15 +1226,13 @@     , _height = lengthFind "height"     , _definitions = defs     , _description = ""-    , _styleRules = cssStyle named     , _documentLocation = rootLocation     }   where-    (parsedElements, named) =-        runState (mapM unparse $ elChildren e) emptyState+    parsedElements = map unparse $ elChildren e     defs = foldl' (foldTree worker) M.empty parsedElements     worker m t =-      case t ^.drawAttr.attrId of+      case t ^.drawAttributes.attrId of         Nothing  -> m         Just tid -> M.insert tid t m     lengthFind n =@@ -1175,7 +1242,7 @@ -- | Transform a SVG document to a XML node. xmlOfDocument :: Document -> X.Element xmlOfDocument doc =-    X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ children)+    X.node (X.unqual "svg") (attrs, descTag ++ children)   where     attr name = X.Attr (X.unqual name)     children = catMaybes [serializeTreeNode el | el <- _elements doc]@@ -1187,12 +1254,6 @@     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 ++