diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/reanimate-svg.cabal b/reanimate-svg.cabal --- a/reanimate-svg.cabal +++ b/reanimate-svg.cabal @@ -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, diff --git a/src/Graphics/SvgTree.hs b/src/Graphics/SvgTree.hs --- a/src/Graphics/SvgTree.hs +++ b/src/Graphics/SvgTree.hs @@ -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 } diff --git a/src/Graphics/SvgTree/Types.hs b/src/Graphics/SvgTree/Types.hs --- a/src/Graphics/SvgTree/Types.hs +++ b/src/Graphics/SvgTree/Types.hs @@ -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 `` 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 `` @@ -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 `` 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 ``. 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 diff --git a/src/Graphics/SvgTree/XmlParser.hs b/src/Graphics/SvgTree/XmlParser.hs --- a/src/Graphics/SvgTree/XmlParser.hs +++ b/src/Graphics/SvgTree/XmlParser.hs @@ -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 ++