diff --git a/reanimate-svg.cabal b/reanimate-svg.cabal index 60273a0..10c8137 100644 --- a/reanimate-svg.cabal +++ b/reanimate-svg.cabal @@ -28,7 +28,7 @@ Source-Repository head library hs-source-dirs: src - ghc-options: -Wall -fsimpl-tick-factor=300 + ghc-options: -Wall -fsimpl-tick-factor=1000 default-language: Haskell2010 exposed-modules: Graphics.SvgTree , Graphics.SvgTree.CssTypes @@ -59,8 +59,8 @@ library , linear >= 1.20 , vector >= 0.10 , text >= 1.1 - , transformers >= 0.3 && < 0.6 - , mtl >= 2.1 && < 2.3 + , transformers >= 0.3 && < 0.7 + , mtl >= 2.1 && < 2.4 , lens >= 4.6 && < 6 , double-conversion >= 2.0.0.0 && < 3.0.0.0 , hashable >= 1.3.0.0 diff --git a/src/Graphics/SvgTree/Types.hs b/src/Graphics/SvgTree/Types.hs index 64781b9..6b626de 100644 --- a/src/Graphics/SvgTree/Types.hs +++ b/src/Graphics/SvgTree/Types.hs @@ -474,6 +474,12 @@ module Graphics.SvgTree.Types , aspectRatioAlign , aspectRatioMeetSlice + -- * Style + , Style( .. ) + , pattern StyleTree + , styleType + , styleContent + -- * MISC functions , zipTree , foldTree diff --git a/src/Graphics/SvgTree/Types/Hashable.hs b/src/Graphics/SvgTree/Types/Hashable.hs index e9e1769..8ec1a68 100644 --- a/src/Graphics/SvgTree/Types/Hashable.hs +++ b/src/Graphics/SvgTree/Types/Hashable.hs @@ -30,6 +30,8 @@ deriving instance Hashable Mask deriving instance Hashable CoordinateUnits +deriving instance Hashable Style + deriving instance Hashable TreeBranch deriving instance Hashable Group @@ -273,5 +275,8 @@ pattern MaskTree n = Tree (MaskNode n) pattern ClipPathTree :: ClipPath -> Tree pattern ClipPathTree n = Tree (ClipPathNode n) +pattern StyleTree :: Style -> Tree +pattern StyleTree n = Tree (StyleNode n) + pattern SvgTree :: Document -> Tree pattern SvgTree n = Tree (SvgNode n) diff --git a/src/Graphics/SvgTree/Types/Internal.hs b/src/Graphics/SvgTree/Types/Internal.hs index 1590f9a..27aa16d 100644 --- a/src/Graphics/SvgTree/Types/Internal.hs +++ b/src/Graphics/SvgTree/Types/Internal.hs @@ -446,6 +446,11 @@ module Graphics.SvgTree.Types.Internal aspectRatioAlign, aspectRatioMeetSlice, + -- * Style + Style(..), + styleType, + styleContent, + -- * MISC functions nameOfTree, toUserUnit, @@ -1193,6 +1198,19 @@ instance WithDefaultSvg Text where _textAdjust = TextAdjustSpacing } +data Style = Style + { _styleType :: !String, + _styleContent :: !String + } + deriving (Eq, Show, Generic) + +instance WithDefaultSvg Style where + defaultSvg = + Style + { _styleType = "", + _styleContent = [] + } + -- | Main type for the scene description, reorient to -- specific type describing each SVG tag. data Tree = CachedTree @@ -1228,6 +1246,7 @@ data TreeBranch | MaskNode !Mask | ClipPathNode !ClipPath | SvgNode !Document + | StyleNode !Style deriving (Eq, Show, Generic) instance WithDefaultSvg TreeBranch where @@ -1924,6 +1943,7 @@ nameOfTree v = MaskNode _ -> "mask" ClipPathNode _ -> "clipPath" SvgNode {} -> "svg" + StyleNode {} -> "style" -- | Defines the possible values for the @spreadMethod@ -- values used for the gradient definitions. @@ -2302,5 +2322,6 @@ makeLenses ''SpecularLighting makeLenses ''DropShadow makeLenses ''DiffuseLighting makeLenses ''ConvolveMatrix +makeLenses ''Style makeClassy ''FilterAttributes diff --git a/src/Graphics/SvgTree/XmlParser.hs b/src/Graphics/SvgTree/XmlParser.hs index 054a7e7..f2f4e59 100644 --- a/src/Graphics/SvgTree/XmlParser.hs +++ b/src/Graphics/SvgTree/XmlParser.hs @@ -24,7 +24,7 @@ import Control.Lens hiding (children, element, import Control.Lens.Unsound import Data.Attoparsec.Text (Parser, parseOnly, string) import Data.List (foldl', intercalate) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import qualified Data.Text as T import Graphics.SvgTree.ColorParser import Graphics.SvgTree.CssParser (complexNumber, dashArray, num, @@ -976,6 +976,7 @@ instance XMLUpdatable Tree where let sub = [X.Elem . setChildren pathNode $ X.elContent textNode] return $ setChildren textNode sub SvgNode doc -> Just $ xmlOfDocument doc + StyleNode s -> serializeTreeNode s isNotNone :: Tree -> Bool @@ -1335,6 +1336,21 @@ instance XMLUpdatable Marker where ,"preserveAspectRatio" `parseIn` markerAspectRatio ] +instance XMLUpdatable Style where + xmlTagName _ = "style" + serializeTreeNode node = + flip setChildren [ + X.Text X.CData + { X.cdVerbatim = X.CDataText + , X.cdData = _styleContent node + , X.cdLine = Nothing + } + ] + <$> genericSerializeNode node + attributes = + ["type" `parseIn` styleType + ] + serializeText :: Text -> Maybe X.Element serializeText topText = namedNode where namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode @@ -1521,7 +1537,15 @@ 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 -> "style") = + StyleTree $ xmlUnparse e & maybe id (styleContent .~) content + where + content = do + c <- listToMaybe $ X.elContent e + d <- case c of + X.Text t -> Just t + _ -> Nothing + pure $ X.cdData d unparse e@(nodeName -> "defs") = DefinitionTree $ xmlUnparseWithDrawAttr e & groupChildren .~ map unparse (elChildren e) unparse e@(nodeName -> "filter") =