svg-tree 0.6.1 → 0.6.2

raw patch · 4 files changed

+141/−125 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• src/Graphics/Svg/ColorParser.hs +111/−111
• src/Graphics/Svg/XmlParser.hs +24/−12
• svg-tree.cabal +2/−2

@@ -1,5 +1,9 @@ -*-change-log-*-
 
+v0.6.2 August 2017
+ * Fix: gather named elements even outside of <defs> tags.
+ * Fix: URL ID now can contain more characters.
+
 v0.6.1: January 2017
  * Fix: some gradient mesh parsing, stop can have style (like with Inkscape 0.92)
  * Fix: norm say "<mesh>" is the global tag

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

@@ -1044,6 +1044,17 @@         s { symbols = M.insert elemId (f el) $ symbols s }
       return None
 
+isDefTag :: String -> Bool
+isDefTag n = n `elem` defList where
+  defList =
+    [ "pattern"
+    , "marker"
+    , "mask"
+    , "clipPath"
+    , "linearGradient"
+    , "meshgradient"
+    , "radialGradient"]
+
 unparseDefs :: X.Element -> State Symbols Tree
 unparseDefs e@(nodeName -> "pattern") = do
   subElements <- mapM unparse $ elChildren e
@@ -1143,19 +1154,20 @@            , _spanContent = textContent
            }
 
-unparse e = pure $ case nodeName e of
-    "image" -> ImageTree parsed
-    "ellipse" -> EllipseTree parsed
-    "rect" -> RectangleTree parsed
-    "polyline" -> PolyLineTree parsed
-    "polygon" -> PolygonTree parsed
-    "circle"-> CircleTree parsed
-    "line"  -> LineTree parsed
-    "path" -> PathTree parsed
+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
     "meshgradient" ->
-      MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e
-    "use" -> UseTree parsed Nothing
-    _ -> None
+      pure $ MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e
+    "use" -> pure $ UseTree parsed Nothing
+    n | isDefTag n -> unparseDefs e
+    _ -> pure None
   where
     parsed :: (XMLUpdatable a, WithDrawAttributes a) => a
     parsed = xmlUnparseWithDrawAttr e

@@ -1,5 +1,5 @@ name:                svg-tree
-version:             0.6.1
+version:             0.6.2
 synopsis:            SVG file loader and serializer
 description:
   svg-tree provides types representing a SVG document,
@@ -29,7 +29,7 @@ Source-Repository this
     Type:      git
     Location:  git://github.com/Twinside/svg-tree.git
-    Tag:       v0.6.1
+    Tag:       v0.6.2
 
 library
   hs-source-dirs: src