From 908fa693caf0a1de01026a7069d579ed526266fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20Jano=C5=A1=C3=ADk?= Date: Fri, 30 Apr 2021 23:39:00 +0200 Subject: [PATCH 1/4] Add `currentColor` value support --- src/Graphics/Svg/ColorParser.hs | 5 ++++- src/Graphics/Svg/Types.hs | 8 ++++---- src/Graphics/Svg/XmlParser.hs | 15 ++++++++------- 3 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/Graphics/Svg/ColorParser.hs b/src/Graphics/Svg/ColorParser.hs index 2b5cc4c..f3c4a81 100644 --- a/src/Graphics/Svg/ColorParser.hs +++ b/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" diff --git a/src/Graphics/Svg/Types.hs b/src/Graphics/Svg/Types.hs index 97fe797..f7b68bb 100644 --- a/src/Graphics/Svg/Types.hs +++ b/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 diff --git a/src/Graphics/Svg/XmlParser.hs b/src/Graphics/Svg/XmlParser.hs index 1a7fd9f..3b95f81 100644 --- a/src/Graphics/Svg/XmlParser.hs +++ b/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 From 6bf80fa9400d72daf7f8035f610348f4d4ad3d00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20Jano=C5=A1=C3=ADk?= Date: Fri, 30 Apr 2021 23:46:01 +0200 Subject: [PATCH 2/4] Identifier escaping --- src/Graphics/Svg/CssParser.hs | 57 +++++++++++++++++++++++++++++------ src/Graphics/Svg/CssTypes.hs | 18 +++++++++-- 2 files changed, 63 insertions(+), 12 deletions(-) diff --git a/src/Graphics/Svg/CssParser.hs b/src/Graphics/Svg/CssParser.hs index 7cac8b7..7d552b8 100644 --- a/src/Graphics/Svg/CssParser.hs +++ b/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 diff --git a/src/Graphics/Svg/CssTypes.hs b/src/Graphics/Svg/CssTypes.hs index e3184a6..f68d065 100644 --- a/src/Graphics/Svg/CssTypes.hs +++ b/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 = "!\"#$%&'()*+,./:;<=>?@[\\]^`{|}~" \ No newline at end of file From 79ebf7602e587003989d837d9c90386fa86cba2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20Jano=C5=A1=C3=ADk?= Date: Sat, 1 May 2021 03:04:53 +0200 Subject: [PATCH 3/4] Use unicode internally by default --- src/Graphics/Svg.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Graphics/Svg.hs b/src/Graphics/Svg.hs index d1a8b22..97b17af 100644 --- a/src/Graphics/Svg.hs +++ b/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 From 9fb8cbccc433e4a2383a4be74ab00e13f1bb14ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20Jano=C5=A1=C3=ADk?= Date: Mon, 17 May 2021 20:27:01 +0200 Subject: [PATCH 4/4] Proper path flag parsing --- src/Graphics/Svg/PathParser.hs | 5 +++-- test/PathParserSpec.hs | 13 ++++++++++--- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/Graphics/Svg/PathParser.hs b/src/Graphics/Svg/PathParser.hs index 4c6cf5b..3562ff9 100644 --- a/src/Graphics/Svg/PathParser.hs +++ b/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 diff --git a/test/PathParserSpec.hs b/test/PathParserSpec.hs index 3954cf6..a6d5dc8 100644 --- a/test/PathParserSpec.hs +++ b/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 \ No newline at end of file