Styles

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

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

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)

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

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") =