Better encoding, currentColor support and identifier escaping

src/Graphics/Svg.hs

@@ -26,6 +26,7 @@ import qualified Data.ByteString as B
 import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import Text.XML.Light.Lexer ( XmlSource )
 import Text.XML.Light.Input( parseXMLDoc )
 import Text.XML.Light.Output( ppcTopElement, prettyConfigPP )
 import Control.Lens
@@ -38,15 +39,17 @@ import Graphics.Svg.XmlParser
 {-import Graphics.Svg.CssParser-}
 
 -- | Try to load an svg file on disc and parse it as
--- a SVG Document.
+-- a SVG Document using UTF-8 encoding.
 loadSvgFile :: FilePath -> IO (Maybe Document)
 loadSvgFile filename =
-  parseSvgFile filename <$> B.readFile filename
+  parseSvgFile filename . T.decodeUtf8 <$> B.readFile filename
 
--- | Parse an in-memory SVG file
-parseSvgFile :: FilePath    -- ^ Source path/URL of the document, used
+-- | Parse an in-memory SVG file.
+-- Note: Using `B.ByteString` can cause issues with multibyte characters.
+parseSvgFile :: XmlSource s
+             => FilePath    -- ^ Source path/URL of the document, used
                             -- to resolve relative links.
-             -> B.ByteString
+             -> s
              -> Maybe Document
 parseSvgFile filename fileContent =
   parseXMLDoc fileContent >>= unparseDocument filename

src/Graphics/Svg/ColorParser.hs

@@ -95,6 +95,7 @@ textureSerializer :: Texture -> String
 textureSerializer (ColorRef px) = colorSerializer px
 textureSerializer (TextureRef str) = printf "url(#%s)" str
 textureSerializer FillNone = "none"
+textureSerializer FillCurrent = "currentColor"
 
 urlRef :: Parser String
 urlRef = string "url(" *> skipSpace *>
@@ -104,8 +105,10 @@ urlRef = string "url(" *> skipSpace *>
 
 textureParser :: Parser Texture
 textureParser =
-  none <|> (TextureRef <$> urlRef)
+  none <|> current
+       <|> (TextureRef <$> urlRef)
        <|> (ColorRef <$> colorParser)
   where
     none = FillNone <$ string "none"
+    current = FillCurrent <$ string "currentColor"
 

src/Graphics/Svg/CssParser.hs

@@ -32,22 +32,25 @@ import Data.Attoparsec.Text
     , letter
     , char
     , digit
-    {-, skip-}
     , sepBy1
     , (<?>)
     , skipMany
     , notChar
     , parseOnly
+    , satisfy
     )
 import qualified Data.Attoparsec.Text as AT
 
 import Data.Attoparsec.Combinator
     ( option
     , sepBy
-    {-, sepBy1-}
+    , many'
     , many1
+    , choice
     )
 
+import Numeric ( readHex )
+import Data.Char ( chr, isAscii, isHexDigit )
 import Codec.Picture( PixelRGBA8( .. ) )
 import Graphics.Svg.Types
 import Graphics.Svg.NamedColors( svgNamedColors )
@@ -74,16 +77,52 @@ num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)
                  <|> doubleNumber
 
 
+-- https://www.w3.org/TR/css-syntax-3/#ident-token-diagram
 ident :: Parser T.Text
-ident =
-  (\f c -> f . T.cons c . T.pack)
-        <$> trailingSub
-        <*> nmstart <*> nmchar
+ident = T.append <$> idstart <*> idtail
   where
-    trailingSub = option id $ T.cons '-' <$ char '-'
+    ts = fmap T.singleton
+    -- https://www.w3.org/TR/css-syntax-3/#would-start-an-identifier
+    idstart :: Parser T.Text
+    idstart = choice
+      [ T.append <$> ts hyphen
+                 <*> ts (namestartcp <|> hyphen <|> escsequence)
+      , ts namestartcp
+      , ts escsequence
+      ]
+    idtail :: Parser T.Text
+    idtail = T.pack <$> many' (namecp <|> escsequence)
+    underscore :: Parser Char
     underscore = char '_'
-    nmstart = letter <|> underscore
-    nmchar = many (letter <|> digit <|> underscore <|> char '-')
+    hyphen :: Parser Char
+    hyphen = char '-'
+    -- https://www.w3.org/TR/css-syntax-3/#name-start-code-point
+    namestartcp :: Parser Char
+    namestartcp = letter <|> underscore <|> nonAscii
+    -- https://www.w3.org/TR/css-syntax-3/#name-code-point
+    namecp :: Parser Char
+    namecp = namestartcp <|> digit <|> hyphen
+    nonAscii :: Parser Char
+    nonAscii = satisfy $ not . isAscii
+    -- https://www.w3.org/TR/css-syntax-3/#escape-diagram
+    escsequence :: Parser Char
+    escsequence = char '\\' *>
+      ((hexUcode "" <* skipOptionalWhitespace) <|> notNewLineOrHex)
+    notNewLineOrHex :: Parser Char
+    notNewLineOrHex = satisfy (\c -> c /= '\n' && not (isHexDigit c))
+    hexUcode :: String -> Parser Char
+    hexUcode xs = case xs of
+      [] -> hex >>= \c -> hexUcode [c]
+      _   | length xs == 6 -> pure $ fromUcode xs
+          | otherwise -> (hex >>= (hexUcode . (:xs))) <|> (pure $ fromUcode xs)
+    hex = satisfy isHexDigit
+    fromUcode :: String -> Char
+    fromUcode = chr . fst . head . readHex . reverse
+    -- https://www.w3.org/TR/css-syntax-3/#whitespace-diagram
+    whitespace :: Parser Char
+    whitespace = satisfy (`elem` (" \n\t" :: String))
+    skipOptionalWhitespace :: Parser ()
+    skipOptionalWhitespace = option () (() <$ whitespace)
 
 str :: Parser T.Text
 str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace

src/Graphics/Svg/CssTypes.hs

@@ -24,7 +24,7 @@ module Graphics.Svg.CssTypes
 import Data.Monoid( mconcat )
 #endif
 
-import Data.Monoid( (<>) )
+import Data.Char (isAscii, ord)
 import Data.List( intersperse )
 import qualified Data.Text as T
 import qualified Data.Text.Lazy.Builder as TB
@@ -61,7 +61,7 @@ instance TextBuildable CssDescriptor where
       AnyElem -> si '*'
       WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']']
      where
-      ft = TB.fromText
+      ft = TB.fromText . escapeSpecialChars
       si = TB.singleton
 
 -- | Define complex selector.
@@ -107,7 +107,7 @@ instance TextBuildable CssRule where
       tserializeDecl d = ft "  " <> tserialize d <> ft ";\n"
       tselector =
           mconcat . intersperse (ft " ") . fmap tserialize
-      tselectors = 
+      tselectors =
           intersperse (ft ",\n") $ fmap tselector selectors
 
 -- | Interface for elements to be matched against
@@ -269,3 +269,15 @@ toUserUnit dpi = go where
     Cm n -> go . Inches $ n / 2.54
     Point n -> go . Inches $ n / 72
 
+-- | Escapes special characters in CSS identifiers.
+-- Does not support unicode sequences.
+escapeSpecialChars :: T.Text -> T.Text
+escapeSpecialChars = T.concatMap escape
+  where
+    escape c
+      | c `elem` cssSpecialChars = T.pack ['\\', c]
+      | isAscii c = T.singleton c
+      | otherwise = T.pack . printf "\\%x " $ ord c
+
+cssSpecialChars :: String
+cssSpecialChars = "!\"#$%&'()*+,./:;<=>?@[\\]^`{|}~"

src/Graphics/Svg/PathParser.hs

@@ -102,11 +102,12 @@ command =  (MoveTo OriginAbsolute <$ string "M" <*> pointList)
           manyComma a = a `sepBy1` commaWsp
 
           numComma = num <* commaWsp
+          flagComma = ((True <$ char '1' <|> False <$ char '0') <* commaWsp)
           ellipticalArgs = (,,,,,) <$> numComma
                                    <*> numComma
                                    <*> numComma
-                                   <*> (fmap (/= 0) numComma)
-                                   <*> (fmap (/= 0) numComma)
+                                   <*> flagComma
+                                   <*> flagComma
                                    <*> point
 
 serializePoint :: RPoint -> String

src/Graphics/Svg/Types.hs

@@ -189,7 +189,6 @@ import Data.Foldable( Foldable )
 import Data.Function( on )
 import Data.List( inits )
 import qualified Data.Map as M
-import Data.Semigroup( Semigroup( .. ) )
 import Data.Monoid( Last( .. ) )
 import qualified Data.Foldable as F
 import qualified Data.Text as T
@@ -314,7 +313,7 @@ data PreserveAspectRatio = PreserveAspectRatio
   deriving (Eq, Show)
 
 instance WithDefaultSvg PreserveAspectRatio where
-  defaultSvg = PreserveAspectRatio 
+  defaultSvg = PreserveAspectRatio
     { _aspectRatioDefer     = False
     , _aspectRatioAlign     = AlignxMidYMid
     , _aspectRatioMeetSlice = Nothing
@@ -345,6 +344,7 @@ data Texture
   = ColorRef   PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb)
   | TextureRef String     -- ^ Link to a complex texture (url(#name))
   | FillNone              -- ^ Equivalent to the `none` value.
+  | FillCurrent           -- ^ Equivalent to the `currentColor` value.
   deriving (Eq, Show)
 
 -- | Describe the possile filling algorithms.
@@ -2193,7 +2193,7 @@ data Pattern = Pattern
       -- attribute.
     , _patternUnit        :: !CoordinateUnits
       -- | Value of the "preserveAspectRatio" attribute
-    , _patternAspectRatio :: !PreserveAspectRatio 
+    , _patternAspectRatio :: !PreserveAspectRatio
       -- | Value of "patternTransform" attribute
     , _patternTransform   :: !(Maybe [Transformation])
     }
@@ -2486,7 +2486,7 @@ instance CssMatcheable Tree where
 --------------------------------------------------------------------------
 --- Dumped
 --------------------------------------------------------------------------
--- makeClassy ''PreserveAspectRatio 
+-- makeClassy ''PreserveAspectRatio
 --
 -- | Lenses for the PreserveAspectRatio type
 class HasPreserveAspectRatio a where

src/Graphics/Svg/XmlParser.hs

@@ -29,7 +29,7 @@ import Control.Applicative( (<|>), many )
 import Control.Lens hiding( transform, children, elements, element )
 import Control.Monad.State.Strict( State, runState, modify, gets )
 import Data.Maybe( fromMaybe, catMaybes )
-import Data.Monoid( Last( Last ), getLast, (<>) )
+import Data.Monoid( Last( Last ), getLast )
 import Data.List( foldl', intercalate )
 import Text.XML.Light.Proc( findAttrBy, elChildren, strContent )
 import qualified Text.XML.Light as X
@@ -128,7 +128,7 @@ instance ParseableAttribute [Transformation] where
 
 instance ParseableAttribute Alignment where
   aparse s = Just $ case s of
-    "none" -> AlignNone 
+    "none" -> AlignNone
     "xMinYMin" -> AlignxMinYMin
     "xMidYMin" -> AlignxMidYMin
     "xMaxYMin" -> AlignxMaxYMin
@@ -141,7 +141,7 @@ instance ParseableAttribute Alignment where
     _ -> _aspectRatioAlign defaultSvg
 
   aserialize v = Just $ case v of
-    AlignNone -> "none" 
+    AlignNone -> "none"
     AlignxMinYMin -> "xMinYMin"
     AlignxMidYMin -> "xMidYMin"
     AlignxMaxYMin -> "xMaxYMin"
@@ -157,7 +157,7 @@ instance ParseableAttribute MeshGradientType where
     "bilinear" -> GradientBilinear
     "bicubic" -> GradientBicubic
     _ -> GradientBilinear
-  
+
   aserialize v = Just $ case v of
     GradientBilinear -> "bilinear"
     GradientBicubic -> "bicubic"
@@ -192,7 +192,7 @@ instance ParseableAttribute PreserveAspectRatio where
             , _aspectRatioAlign = alignOf align
             }
       ["defer", align, meet] ->
-          Just $ PreserveAspectRatio 
+          Just $ PreserveAspectRatio
               { _aspectRatioDefer = True
               , _aspectRatioAlign = alignOf align
               , _aspectRatioMeetSlice = aparse meet
@@ -523,6 +523,7 @@ cssUniqueTexture :: ASetter el el
                  -> CssUpdater el
 cssUniqueTexture setter attr css = case css of
   ((CssIdent "none":_):_) -> attr & setter .~ Last (Just FillNone)
+  ((CssIdent "currentColor":_):_) -> attr & setter .~ Last (Just FillCurrent)
   ((CssColor c:_):_) -> attr & setter .~ Last (Just $ ColorRef c)
   ((CssFunction "url" [CssReference c]:_):_) ->
         attr & setter .~ Last (Just . TextureRef $ T.unpack c)
@@ -908,7 +909,7 @@ serializeText topText = namedNode where
     (Nothing, Nothing) -> Nothing
     (Just a, Nothing) -> Just $ setChildren a subContent
     (Nothing, Just b) -> Just $ setChildren b subContent
-    (Just a, Just b) -> 
+    (Just a, Just b) ->
         Just $ setChildren (mergeAttributes a b) subContent
     where
       info = genericSerializeNode $ _spanInfo tspan
@@ -1004,7 +1005,7 @@ instance XMLUpdatable GradientStop where
           [(opacitySetter "stop-opacity" gradientOpacity, (cssUniqueFloat gradientOpacity))
           ,("stop-color" `parseIn` gradientColor, cssUniqueColor gradientColor)
           ]
-      
+
       lst =
         [gradientOffsetSetter
         ,"path" `parseIn` gradientPath

test/PathParserSpec.hs

@@ -11,8 +11,15 @@ import Test.Hspec
 spec :: Spec
 spec = do
   describe "num" $ do
+    let d = "M-.10 .10z"
+        p = MoveTo OriginAbsolute [V2 (-0.1) 0.10]
     it "support shorthand number" $ do
       parseOnly command d `shouldBe` Right p
-      where
-        d = "M-.10 .10z"
-        p = MoveTo OriginAbsolute [V2 (-0.1) 0.10]
+  describe "arc" $ do
+    let d = "a1.3 1.3 0 01-1.3-1.3"
+    --                  ^^ Those two numbers are 2 flags.
+    -- This is valid SVG sequence according to https://www.w3.org/TR/SVG/paths.html#PathDataBNF
+    -- as flag can be only "0" or "1" and separator is optional.
+        p = EllipticalArc OriginRelative [(1.3, 1.3, 0, False, True, V2 (-1.3) (-1.3))]
+    it "support flags without separators" $ do
+      parseOnly command d `shouldBe` Right p