diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,11 +1,14 @@ --*-change-log-*- - -v0.1.0.2 March 2014 - * Fix: Bumping lens bounds - -v0.1.0.1 - * Fix: Lowering some lower bounds - -v0.1 - * Initial release - +-*-change-log-*- + +v0.1.1 April 2015 + * Fix: Bumping lens bounds + +v0.1.0.2 March 2015 + * Fix: Bumping lens bounds + +v0.1.0.1 + * Fix: Lowering some lower bounds + +v0.1 + * Initial release + diff --git a/src/Graphics/Svg.hs b/src/Graphics/Svg.hs --- a/src/Graphics/Svg.hs +++ b/src/Graphics/Svg.hs @@ -1,107 +1,111 @@ --- | Module providing basic input/output for the SVG document, --- for document building, please refer to Graphics.Svg.Types. -module Graphics.Svg ( -- * Saving/Loading functions - loadSvgFile - , parseSvgFile - , xmlOfDocument - , saveXmlFile - - -- * Manipulation functions - , cssApply - , cssRulesOfText - , applyCSSRules - , resolveUses - - -- * Type definitions - , module Graphics.Svg.Types - ) where - -import Control.Applicative( (<$>) ) -import Data.List( foldl' ) -import qualified Data.ByteString as B -import qualified Data.Map as M -import qualified Data.Text as T -import Text.XML.Light.Input( parseXMLDoc ) -import Text.XML.Light.Output( ppcTopElement, prettyConfigPP ) -import Control.Lens - -import Graphics.Svg.Types -import Graphics.Svg.CssTypes -import Graphics.Svg.CssParser( cssRulesOfText ) -import Graphics.Svg.XmlParser - -{-import Graphics.Svg.CssParser-} - --- | Try to load an svg file on disc and parse it as --- a SVG Document. -loadSvgFile :: FilePath -> IO (Maybe Document) -loadSvgFile filename = - parseSvgFile filename <$> B.readFile filename - --- | Parse an in-memory SVG file -parseSvgFile :: FilePath -- ^ Source path/URL of the document, used - -- to resolve relative links. - -> B.ByteString - -> Maybe Document -parseSvgFile filename fileContent = - parseXMLDoc fileContent >>= unparseDocument filename - --- | Save a svg Document on a file on disk. -saveXmlFile :: FilePath -> Document -> IO () -saveXmlFile filePath = - writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument - -cssDeclApplyer :: DrawAttributes -> CssDeclaration - -> DrawAttributes -cssDeclApplyer value (CssDeclaration txt elems) = - case lookup txt cssUpdaters of - Nothing -> value - Just f -> f value elems - where - cssUpdaters = [(T.pack $ _attributeName n, u) | - (n, u) <- drawAttributesList] - --- | Rewrite a SVG Tree using some CSS rules. --- --- This action will propagate the definition of the --- css directly in each matched element. -cssApply :: [CssRule] -> Tree -> Tree -cssApply rules = zipTree go where - go [] = None - go ([]:_) = None - go context@((t:_):_) = t & drawAttr .~ attr' - where - matchingDeclarations = - findMatchingDeclarations rules context - attr = view drawAttr t - attr' = foldl' cssDeclApplyer attr matchingDeclarations - --- | For every 'use' tag, try to resolve the geometry associated --- with it and place it in the scene Tree. It is important to --- resolve the 'use' tag before applying the CSS rules, as some --- rules may apply some elements matching the children of "use". -resolveUses :: Document -> Document -resolveUses doc = - doc { _elements = mapTree fetchUses <$> _elements doc } - where - fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo - fetchUses a = a - - search nfo = maybe Nothing geometryExtract found where - found = M.lookup (_useName nfo) $ _definitions doc - - geometryExtract c = case c of - ElementLinearGradient _ -> Nothing - ElementRadialGradient _ -> Nothing - ElementMask _ -> Nothing - ElementClipPath _ -> Nothing - ElementGeometry t -> Just t - ElementPattern _ -> Nothing - ElementMarker _ -> Nothing - --- | Rewrite the document by applying the CSS rules embedded --- inside it. -applyCSSRules :: Document -> Document -applyCSSRules doc = doc - { _elements = cssApply (_styleRules doc) <$> _elements doc } - +{-# LANGUAGE CPP #-} +-- | Module providing basic input/output for the SVG document, +-- for document building, please refer to Graphics.Svg.Types. +module Graphics.Svg ( -- * Saving/Loading functions + loadSvgFile + , parseSvgFile + , xmlOfDocument + , saveXmlFile + + -- * Manipulation functions + , cssApply + , cssRulesOfText + , applyCSSRules + , resolveUses + + -- * Type definitions + , module Graphics.Svg.Types + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.List( foldl' ) +import qualified Data.ByteString as B +import qualified Data.Map as M +import qualified Data.Text as T +import Text.XML.Light.Input( parseXMLDoc ) +import Text.XML.Light.Output( ppcTopElement, prettyConfigPP ) +import Control.Lens + +import Graphics.Svg.Types +import Graphics.Svg.CssTypes +import Graphics.Svg.CssParser( cssRulesOfText ) +import Graphics.Svg.XmlParser + +{-import Graphics.Svg.CssParser-} + +-- | Try to load an svg file on disc and parse it as +-- a SVG Document. +loadSvgFile :: FilePath -> IO (Maybe Document) +loadSvgFile filename = + parseSvgFile filename <$> B.readFile filename + +-- | Parse an in-memory SVG file +parseSvgFile :: FilePath -- ^ Source path/URL of the document, used + -- to resolve relative links. + -> B.ByteString + -> Maybe Document +parseSvgFile filename fileContent = + parseXMLDoc fileContent >>= unparseDocument filename + +-- | Save a svg Document on a file on disk. +saveXmlFile :: FilePath -> Document -> IO () +saveXmlFile filePath = + writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument + +cssDeclApplyer :: DrawAttributes -> CssDeclaration + -> DrawAttributes +cssDeclApplyer value (CssDeclaration txt elems) = + case lookup txt cssUpdaters of + Nothing -> value + Just f -> f value elems + where + cssUpdaters = [(T.pack $ _attributeName n, u) | + (n, u) <- drawAttributesList] + +-- | Rewrite a SVG Tree using some CSS rules. +-- +-- This action will propagate the definition of the +-- css directly in each matched element. +cssApply :: [CssRule] -> Tree -> Tree +cssApply rules = zipTree go where + go [] = None + go ([]:_) = None + go context@((t:_):_) = t & drawAttr .~ attr' + where + matchingDeclarations = + findMatchingDeclarations rules context + attr = view drawAttr t + attr' = foldl' cssDeclApplyer attr matchingDeclarations + +-- | For every 'use' tag, try to resolve the geometry associated +-- with it and place it in the scene Tree. It is important to +-- resolve the 'use' tag before applying the CSS rules, as some +-- rules may apply some elements matching the children of "use". +resolveUses :: Document -> Document +resolveUses doc = + doc { _elements = mapTree fetchUses <$> _elements doc } + where + fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo + fetchUses a = a + + search nfo = maybe Nothing geometryExtract found where + found = M.lookup (_useName nfo) $ _definitions doc + + geometryExtract c = case c of + ElementLinearGradient _ -> Nothing + ElementRadialGradient _ -> Nothing + ElementMask _ -> Nothing + ElementClipPath _ -> Nothing + ElementGeometry t -> Just t + ElementPattern _ -> Nothing + ElementMarker _ -> Nothing + +-- | Rewrite the document by applying the CSS rules embedded +-- inside it. +applyCSSRules :: Document -> Document +applyCSSRules doc = doc + { _elements = cssApply (_styleRules doc) <$> _elements doc } + diff --git a/src/Graphics/Svg/ColorParser.hs b/src/Graphics/Svg/ColorParser.hs --- a/src/Graphics/Svg/ColorParser.hs +++ b/src/Graphics/Svg/ColorParser.hs @@ -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 Float - 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 Float + 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" + diff --git a/src/Graphics/Svg/CssParser.hs b/src/Graphics/Svg/CssParser.hs --- a/src/Graphics/Svg/CssParser.hs +++ b/src/Graphics/Svg/CssParser.hs @@ -1,257 +1,257 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -module Graphics.Svg.CssParser - ( CssElement( .. ) - , complexNumber - , declaration - , ruleSet - , styleString - , dashArray - , numberList - , num - , cssRulesOfText - ) - where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<*), (*>) - , pure - ) -#endif - -import Control.Applicative( (<$>), (<$) - , (<|>) - , many - ) -import Data.Attoparsec.Text - ( Parser - , double - , string - , skipSpace - , letter - , char - , digit - {-, skip-} - , sepBy1 - , () - , skipMany - , notChar - , parseOnly - ) -import qualified Data.Attoparsec.Text as AT - -import Data.Attoparsec.Combinator - ( option - , sepBy - {-, sepBy1-} - , many1 - ) - -import Codec.Picture( PixelRGBA8( .. ) ) -import Graphics.Svg.Types -import Graphics.Svg.NamedColors( svgNamedColors ) -import Graphics.Svg.ColorParser( colorParser ) -import Graphics.Svg.CssTypes -import qualified Data.Text as T -import qualified Data.Map as M -{-import Graphics.Rasterific.Linear( V2( V2 ) )-} -{-import Graphics.Rasterific.Transformations-} - -num :: Parser Float -num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) - where doubleNumber = char '.' *> (scale <$> double) - <|> double - - scalingCoeff n = 10 ^ digitCount - where digitCount :: Int - digitCount = ceiling . logBase 10 $ abs n - - scale n = n / scalingCoeff n - - plusMinus = negate <$ string "-" <*> doubleNumber - <|> string "+" *> doubleNumber - <|> doubleNumber - - -ident :: Parser T.Text -ident = - (\f c -> f . T.cons c . T.pack) - <$> trailingSub - <*> nmstart <*> nmchar - where - trailingSub = option id $ T.cons '-' <$ char '-' - underscore = char '_' - nmstart = letter <|> underscore - nmchar = many (letter <|> digit <|> underscore <|> char '-') - -str :: Parser T.Text -str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace - "str" - -between :: Char -> Char -> Parser a -> Parser a -between o e p = - (skipSpace *> - char o *> skipSpace *> p - <* skipSpace <* char e <* skipSpace) - ("between " ++ [o, e]) - -bracket :: Parser a -> Parser a -bracket = between '[' ']' - - -comment :: Parser () -comment = string "/*" *> toStar *> skipSpace - where - toStar = skipMany (notChar '*') *> char '*' *> testEnd - testEnd = (() <$ char '/') <|> toStar - -cleanSpace :: Parser () -cleanSpace = skipSpace <* many comment - --- | combinator: '+' S* | '>' S* -combinator :: Parser CssSelector -combinator = parse <* cleanSpace where - parse = Nearby <$ char '+' - <|> DirectChildren <$ char '>' - "combinator" - --- unary_operator : '-' | '+' ; - -commaWsp :: Parser Char -commaWsp = skipSpace *> option ',' (char ',') <* skipSpace - -ruleSet :: Parser CssRule -ruleSet = cleanSpace *> rule where - rule = CssRule - <$> selector `sepBy1` commaWsp - <*> (between '{' '}' styleString) - "cssrule" - -styleString :: Parser [CssDeclaration] -styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp - "styleString" - where semiWsp = skipSpace *> char ';' <* skipSpace - mayWsp = option ';' semiWsp - -selector :: Parser [CssSelector] -selector = (:) - <$> (AllOf <$> simpleSelector <* skipSpace "firstpart:(") - <*> ((next <|> return []) "secondpart") - "selector" - where - combOpt :: Parser ([CssSelector] -> [CssSelector]) - - combOpt = cleanSpace *> option id ((:) <$> combinator) - next :: Parser [CssSelector] - next = id <$> combOpt <*> selector - -simpleSelector :: Parser [CssDescriptor] -simpleSelector = (:) <$> elementName <*> many whole - <|> (many1 whole "inmany") - "simple selector" - where - whole = pseudo <|> hash <|> classParser <|> attrib - "whole" - pseudo = char ':' *> (OfPseudoClass <$> ident) - "pseudo" - hash = char '#' *> (OfId <$> ident) - "hash" - classParser = char '.' *> (OfClass <$> ident) - "classParser" - - elementName = el <* skipSpace "elementName" - where el = (OfName <$> ident) - <|> AnyElem <$ char '*' - - attrib = bracket - (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str)) - "attrib") - -declaration :: Parser CssDeclaration -declaration = - CssDeclaration <$> property - <*> (char ':' - *> cleanSpace - *> many1 expr - <* prio - ) - "declaration" - where - property = (ident <* cleanSpace) "property" - prio = option "" $ string "!important" - -operator :: Parser CssElement -operator = skipSpace *> op <* skipSpace - where - op = CssOpSlash <$ char '/' - <|> CssOpComa <$ char ',' - "operator" - -expr :: Parser [CssElement] -expr = ((:) <$> term <*> (concat <$> many termOp)) - "expr" - where - op = option (:[]) $ (\a b -> [a, b]) <$> operator - termOp = ($) <$> op <*> term - -dashArray :: Parser [Number] -dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp) - -numberList :: Parser [Float] -numberList = skipSpace *> (num `sepBy1` commaWsp) - -complexNumber :: Parser Number -complexNumber = do - n <- num - (Percent (n / 100) <$ char '%') - <|> (Em n <$ string "em") - <|> (Mm n <$ string "mm") - <|> (Cm n <$ string "cm") - <|> (Point n <$ string "pt") - <|> (Pc n <$ string "pc") - <|> (Px n <$ string "px") - <|> (Inches n <$ string "in") - <|> pure (Num n) - -term :: Parser CssElement -term = checkRgb <$> function - <|> (CssNumber <$> complexNumber) - <|> (CssString <$> str) - <|> (checkNamedColor <$> ident) - <|> (CssColor <$> colorParser) - where - comma = skipSpace *> char ',' <* skipSpace - checkNamedColor n - | Just c <- M.lookup n svgNamedColors = CssColor c - | otherwise = CssIdent n - - ref = char '#' *> ident - - checkRgb (CssFunction "rgb" - [CssNumber r, CssNumber g, CssNumber b]) = - CssColor $ PixelRGBA8 (to r) (to g) (to b) 255 - where clamp = max 0 . min 255 - to (Num n) = floor $ clamp n - to (Px n) = floor $ clamp n - to (Percent p) = floor . clamp $ p * 255 - to (Em c) = floor $ clamp c - to (Pc n) = floor $ clamp n - to (Mm n) = floor $ clamp n - to (Cm n) = floor $ clamp n - to (Point n) = floor $ clamp n - to (Inches n) = floor $ clamp n - - checkRgb a = a - functionParam = (CssReference <$> ref) <|> term - - function = CssFunction - <$> ident <* char '(' - <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace - --- | Parse CSS text into rules. -cssRulesOfText :: T.Text -> [CssRule] -cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of - Left _ -> [] - Right rules -> rules - +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +module Graphics.Svg.CssParser + ( CssElement( .. ) + , complexNumber + , declaration + , ruleSet + , styleString + , dashArray + , numberList + , num + , cssRulesOfText + ) + where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<*), (*>) + , (<$>), (<$) + , pure + ) +#endif + +import Control.Applicative( (<|>) + , many + ) +import Data.Attoparsec.Text + ( Parser + , double + , string + , skipSpace + , letter + , char + , digit + {-, skip-} + , sepBy1 + , () + , skipMany + , notChar + , parseOnly + ) +import qualified Data.Attoparsec.Text as AT + +import Data.Attoparsec.Combinator + ( option + , sepBy + {-, sepBy1-} + , many1 + ) + +import Codec.Picture( PixelRGBA8( .. ) ) +import Graphics.Svg.Types +import Graphics.Svg.NamedColors( svgNamedColors ) +import Graphics.Svg.ColorParser( colorParser ) +import Graphics.Svg.CssTypes +import qualified Data.Text as T +import qualified Data.Map as M +{-import Graphics.Rasterific.Linear( V2( V2 ) )-} +{-import Graphics.Rasterific.Transformations-} + +num :: Parser Float +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber = char '.' *> (scale <$> double) + <|> double + + scalingCoeff n = 10 ^ digitCount + where digitCount :: Int + digitCount = ceiling . logBase 10 $ abs n + + scale n = n / scalingCoeff n + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + + +ident :: Parser T.Text +ident = + (\f c -> f . T.cons c . T.pack) + <$> trailingSub + <*> nmstart <*> nmchar + where + trailingSub = option id $ T.cons '-' <$ char '-' + underscore = char '_' + nmstart = letter <|> underscore + nmchar = many (letter <|> digit <|> underscore <|> char '-') + +str :: Parser T.Text +str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace + "str" + +between :: Char -> Char -> Parser a -> Parser a +between o e p = + (skipSpace *> + char o *> skipSpace *> p + <* skipSpace <* char e <* skipSpace) + ("between " ++ [o, e]) + +bracket :: Parser a -> Parser a +bracket = between '[' ']' + + +comment :: Parser () +comment = string "/*" *> toStar *> skipSpace + where + toStar = skipMany (notChar '*') *> char '*' *> testEnd + testEnd = (() <$ char '/') <|> toStar + +cleanSpace :: Parser () +cleanSpace = skipSpace <* many comment + +-- | combinator: '+' S* | '>' S* +combinator :: Parser CssSelector +combinator = parse <* cleanSpace where + parse = Nearby <$ char '+' + <|> DirectChildren <$ char '>' + "combinator" + +-- unary_operator : '-' | '+' ; + +commaWsp :: Parser Char +commaWsp = skipSpace *> option ',' (char ',') <* skipSpace + +ruleSet :: Parser CssRule +ruleSet = cleanSpace *> rule where + rule = CssRule + <$> selector `sepBy1` commaWsp + <*> (between '{' '}' styleString) + "cssrule" + +styleString :: Parser [CssDeclaration] +styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp + "styleString" + where semiWsp = skipSpace *> char ';' <* skipSpace + mayWsp = option ';' semiWsp + +selector :: Parser [CssSelector] +selector = (:) + <$> (AllOf <$> simpleSelector <* skipSpace "firstpart:(") + <*> ((next <|> return []) "secondpart") + "selector" + where + combOpt :: Parser ([CssSelector] -> [CssSelector]) + + combOpt = cleanSpace *> option id ((:) <$> combinator) + next :: Parser [CssSelector] + next = id <$> combOpt <*> selector + +simpleSelector :: Parser [CssDescriptor] +simpleSelector = (:) <$> elementName <*> many whole + <|> (many1 whole "inmany") + "simple selector" + where + whole = pseudo <|> hash <|> classParser <|> attrib + "whole" + pseudo = char ':' *> (OfPseudoClass <$> ident) + "pseudo" + hash = char '#' *> (OfId <$> ident) + "hash" + classParser = char '.' *> (OfClass <$> ident) + "classParser" + + elementName = el <* skipSpace "elementName" + where el = (OfName <$> ident) + <|> AnyElem <$ char '*' + + attrib = bracket + (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str)) + "attrib") + +declaration :: Parser CssDeclaration +declaration = + CssDeclaration <$> property + <*> (char ':' + *> cleanSpace + *> many1 expr + <* prio + ) + "declaration" + where + property = (ident <* cleanSpace) "property" + prio = option "" $ string "!important" + +operator :: Parser CssElement +operator = skipSpace *> op <* skipSpace + where + op = CssOpSlash <$ char '/' + <|> CssOpComa <$ char ',' + "operator" + +expr :: Parser [CssElement] +expr = ((:) <$> term <*> (concat <$> many termOp)) + "expr" + where + op = option (:[]) $ (\a b -> [a, b]) <$> operator + termOp = ($) <$> op <*> term + +dashArray :: Parser [Number] +dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp) + +numberList :: Parser [Float] +numberList = skipSpace *> (num `sepBy1` commaWsp) + +complexNumber :: Parser Number +complexNumber = do + n <- num + (Percent (n / 100) <$ char '%') + <|> (Em n <$ string "em") + <|> (Mm n <$ string "mm") + <|> (Cm n <$ string "cm") + <|> (Point n <$ string "pt") + <|> (Pc n <$ string "pc") + <|> (Px n <$ string "px") + <|> (Inches n <$ string "in") + <|> pure (Num n) + +term :: Parser CssElement +term = checkRgb <$> function + <|> (CssNumber <$> complexNumber) + <|> (CssString <$> str) + <|> (checkNamedColor <$> ident) + <|> (CssColor <$> colorParser) + where + comma = skipSpace *> char ',' <* skipSpace + checkNamedColor n + | Just c <- M.lookup n svgNamedColors = CssColor c + | otherwise = CssIdent n + + ref = char '#' *> ident + + checkRgb (CssFunction "rgb" + [CssNumber r, CssNumber g, CssNumber b]) = + CssColor $ PixelRGBA8 (to r) (to g) (to b) 255 + where clamp = max 0 . min 255 + to (Num n) = floor $ clamp n + to (Px n) = floor $ clamp n + to (Percent p) = floor . clamp $ p * 255 + to (Em c) = floor $ clamp c + to (Pc n) = floor $ clamp n + to (Mm n) = floor $ clamp n + to (Cm n) = floor $ clamp n + to (Point n) = floor $ clamp n + to (Inches n) = floor $ clamp n + + checkRgb a = a + functionParam = (CssReference <$> ref) <|> term + + function = CssFunction + <$> ident <* char '(' + <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace + +-- | Parse CSS text into rules. +cssRulesOfText :: T.Text -> [CssRule] +cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of + Left _ -> [] + Right rules -> rules + diff --git a/src/Graphics/Svg/PathParser.hs b/src/Graphics/Svg/PathParser.hs --- a/src/Graphics/Svg/PathParser.hs +++ b/src/Graphics/Svg/PathParser.hs @@ -1,226 +1,226 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Graphics.Svg.PathParser( transformParser - , command - , viewBoxParser - , pointData - , serializePoints - , serializeCommand - , serializeCommands - , serializeViewBox - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<*), (*>) ) -#endif - -import Control.Applicative( (<$>), (<$), (<|>) ) -import Data.Scientific( toRealFloat ) -import Data.Attoparsec.Text - ( Parser - , scientific - , string - , skipSpace - , char - ) -import Data.Attoparsec.Combinator( option - , sepBy - , sepBy1 ) - -import Linear hiding ( angle, point ) -import Graphics.Svg.Types -import qualified Data.Text as T -import Text.Printf( printf ) - -num :: Parser Float -num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) - where doubleNumber :: Parser Float - doubleNumber = toRealFloat <$> scientific - - plusMinus = negate <$ string "-" <*> doubleNumber - <|> string "+" *> doubleNumber - <|> doubleNumber - -viewBoxParser :: Parser (Int, Int, Int, Int) -viewBoxParser = (,,,) - <$> iParse <*> iParse <*> iParse <*> iParse - where - iParse = floor <$> num <* skipSpace - -serializeViewBox :: (Int, Int, Int, Int) -> String -serializeViewBox (a, b, c, d) = printf "%d %d %d %d" a b c d - -commaWsp :: Parser () -commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace - -point :: Parser RPoint -point = V2 <$> num <* commaWsp <*> num - -pointData :: Parser [RPoint] -pointData = point `sepBy` commaWsp - -command :: Parser PathCommand -command = (MoveTo OriginAbsolute <$ string "M" <*> pointList) - <|> (MoveTo OriginRelative <$ string "m" <*> pointList) - <|> (LineTo OriginAbsolute <$ string "L" <*> pointList) - <|> (LineTo OriginRelative <$ string "l" <*> pointList) - <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList) - <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList) - <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList) - <|> (VerticalTo OriginRelative <$ string "v" <*> coordList) - <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs) - <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs) - <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList) - <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList) - <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList) - <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList) - <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList) - <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList) - <|> (ElipticalArc OriginAbsolute <$ string "A" <*> manyComma elipticalArgs) - <|> (ElipticalArc OriginRelative <$ string "a" <*> manyComma elipticalArgs) - <|> (EndPath <$ string "Z") - <|> (EndPath <$ string "z") - where pointList = point `sepBy1` commaWsp - pointPair = (,) <$> point <* commaWsp <*> point - pointPairList = pointPair `sepBy1` commaWsp - coordList = num `sepBy1` commaWsp - curveToArgs = (,,) <$> (point <* commaWsp) - <*> (point <* commaWsp) - <*> point - manyComma a = a `sepBy1` commaWsp - - numComma = num <* commaWsp - elipticalArgs = (,,,,,) <$> numComma - <*> numComma - <*> numComma - <*> numComma - <*> numComma - <*> point - -serializePoint :: RPoint -> String -serializePoint (V2 x y) = printf "%g,%g" x y - -serializePoints :: [RPoint] -> String -serializePoints = unwords . fmap serializePoint - -serializeCoords :: [Coord] -> String -serializeCoords = unwords . fmap (printf "%g") - -serializePointPair :: (RPoint, RPoint) -> String -serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b - -serializePointPairs :: [(RPoint, RPoint)] -> String -serializePointPairs = unwords . fmap serializePointPair - -serializePointTriplet :: (RPoint, RPoint, RPoint) -> String -serializePointTriplet (a, b, c) = - serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c - -serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String -serializePointTriplets = unwords . fmap serializePointTriplet - -serializeCommands :: [PathCommand] -> String -serializeCommands = unwords . fmap serializeCommand - -serializeCommand :: PathCommand -> String -serializeCommand p = case p of - MoveTo OriginAbsolute points -> "M" ++ serializePoints points - MoveTo OriginRelative points -> "m" ++ serializePoints points - LineTo OriginAbsolute points -> "L" ++ serializePoints points - LineTo OriginRelative points -> "l" ++ serializePoints points - - HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords - HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords - VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords - VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords - - CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets - CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets - SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs - SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs - QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs - QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs - SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points - SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points - ElipticalArc OriginAbsolute args -> "A" ++ serializeArgs args - ElipticalArc OriginRelative args -> "a" ++ serializeArgs args - EndPath -> "Z" - where - serializeArg (a, b, c, d, e, V2 x y) = - printf "%g %g %g %g %g %g,%g" a b c d e x y - serializeArgs = unwords . fmap serializeArg - - - -transformParser :: Parser Transformation -transformParser = matrixParser - <|> translationParser - <|> scaleParser - <|> rotateParser - <|> skewYParser - <|> skewXParser - -functionParser :: T.Text -> Parser [Float] -functionParser funcName = - string funcName *> skipSpace - *> char '(' *> skipSpace - *> num `sepBy1` commaWsp - <* skipSpace <* char ')' <* skipSpace - -translationParser :: Parser Transformation -translationParser = do - args <- functionParser "translate" - return $ case args of - [x] -> Translate x 0 - [x, y] -> Translate x y - _ -> TransformUnknown - -skewXParser :: Parser Transformation -skewXParser = do - args <- functionParser "skewX" - return $ case args of - [x] -> SkewX x - _ -> TransformUnknown - -skewYParser :: Parser Transformation -skewYParser = do - args <- functionParser "skewY" - return $ case args of - [x] -> SkewY x - _ -> TransformUnknown - - -scaleParser :: Parser Transformation -scaleParser = do - args <- functionParser "scale" - return $ case args of - [x] -> Scale x Nothing - [x, y] -> Scale x (Just y) - _ -> TransformUnknown - -matrixParser :: Parser Transformation -matrixParser = do - args <- functionParser "matrix" - return $ case args of - [a, b, c, d, e, f] -> - TransformMatrix a b c d e f - _ -> TransformUnknown - -rotateParser :: Parser Transformation -rotateParser = do - args <- functionParser "rotate" - return $ case args of - [angle] -> Rotate angle Nothing - [angle, x, y] -> Rotate angle $ Just (x, y) - _ -> TransformUnknown -{- -rotate( [ ]), which specifies a rotation by degrees about a given point. - -If optional parameters and are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0]. - -If optional parameters and are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(, ) rotate() translate(-, -). - -skewX(), which specifies a skew transformation along the x-axis. - -skewY(), which specifies a skew transformation along the y-axis. - -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Graphics.Svg.PathParser( transformParser + , command + , viewBoxParser + , pointData + , serializePoints + , serializeCommand + , serializeCommands + , serializeViewBox + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) ) +#endif + +import Control.Applicative( (<|>) ) +import Data.Scientific( toRealFloat ) +import Data.Attoparsec.Text + ( Parser + , scientific + , string + , skipSpace + , char + ) +import Data.Attoparsec.Combinator( option + , sepBy + , sepBy1 ) + +import Linear hiding ( angle, point ) +import Graphics.Svg.Types +import qualified Data.Text as T +import Text.Printf( printf ) + +num :: Parser Float +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber :: Parser Float + doubleNumber = toRealFloat <$> scientific + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + +viewBoxParser :: Parser (Int, Int, Int, Int) +viewBoxParser = (,,,) + <$> iParse <*> iParse <*> iParse <*> iParse + where + iParse = floor <$> num <* skipSpace + +serializeViewBox :: (Int, Int, Int, Int) -> String +serializeViewBox (a, b, c, d) = printf "%d %d %d %d" a b c d + +commaWsp :: Parser () +commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace + +point :: Parser RPoint +point = V2 <$> num <* commaWsp <*> num + +pointData :: Parser [RPoint] +pointData = point `sepBy` commaWsp + +command :: Parser PathCommand +command = (MoveTo OriginAbsolute <$ string "M" <*> pointList) + <|> (MoveTo OriginRelative <$ string "m" <*> pointList) + <|> (LineTo OriginAbsolute <$ string "L" <*> pointList) + <|> (LineTo OriginRelative <$ string "l" <*> pointList) + <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList) + <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList) + <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList) + <|> (VerticalTo OriginRelative <$ string "v" <*> coordList) + <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs) + <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs) + <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList) + <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList) + <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList) + <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList) + <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList) + <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList) + <|> (ElipticalArc OriginAbsolute <$ string "A" <*> manyComma elipticalArgs) + <|> (ElipticalArc OriginRelative <$ string "a" <*> manyComma elipticalArgs) + <|> (EndPath <$ string "Z") + <|> (EndPath <$ string "z") + where pointList = point `sepBy1` commaWsp + pointPair = (,) <$> point <* commaWsp <*> point + pointPairList = pointPair `sepBy1` commaWsp + coordList = num `sepBy1` commaWsp + curveToArgs = (,,) <$> (point <* commaWsp) + <*> (point <* commaWsp) + <*> point + manyComma a = a `sepBy1` commaWsp + + numComma = num <* commaWsp + elipticalArgs = (,,,,,) <$> numComma + <*> numComma + <*> numComma + <*> numComma + <*> numComma + <*> point + +serializePoint :: RPoint -> String +serializePoint (V2 x y) = printf "%g,%g" x y + +serializePoints :: [RPoint] -> String +serializePoints = unwords . fmap serializePoint + +serializeCoords :: [Coord] -> String +serializeCoords = unwords . fmap (printf "%g") + +serializePointPair :: (RPoint, RPoint) -> String +serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b + +serializePointPairs :: [(RPoint, RPoint)] -> String +serializePointPairs = unwords . fmap serializePointPair + +serializePointTriplet :: (RPoint, RPoint, RPoint) -> String +serializePointTriplet (a, b, c) = + serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c + +serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String +serializePointTriplets = unwords . fmap serializePointTriplet + +serializeCommands :: [PathCommand] -> String +serializeCommands = unwords . fmap serializeCommand + +serializeCommand :: PathCommand -> String +serializeCommand p = case p of + MoveTo OriginAbsolute points -> "M" ++ serializePoints points + MoveTo OriginRelative points -> "m" ++ serializePoints points + LineTo OriginAbsolute points -> "L" ++ serializePoints points + LineTo OriginRelative points -> "l" ++ serializePoints points + + HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords + HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords + VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords + VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords + + CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets + CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets + SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs + SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs + QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs + QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs + SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points + SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points + ElipticalArc OriginAbsolute args -> "A" ++ serializeArgs args + ElipticalArc OriginRelative args -> "a" ++ serializeArgs args + EndPath -> "Z" + where + serializeArg (a, b, c, d, e, V2 x y) = + printf "%g %g %g %g %g %g,%g" a b c d e x y + serializeArgs = unwords . fmap serializeArg + + + +transformParser :: Parser Transformation +transformParser = matrixParser + <|> translationParser + <|> scaleParser + <|> rotateParser + <|> skewYParser + <|> skewXParser + +functionParser :: T.Text -> Parser [Float] +functionParser funcName = + string funcName *> skipSpace + *> char '(' *> skipSpace + *> num `sepBy1` commaWsp + <* skipSpace <* char ')' <* skipSpace + +translationParser :: Parser Transformation +translationParser = do + args <- functionParser "translate" + return $ case args of + [x] -> Translate x 0 + [x, y] -> Translate x y + _ -> TransformUnknown + +skewXParser :: Parser Transformation +skewXParser = do + args <- functionParser "skewX" + return $ case args of + [x] -> SkewX x + _ -> TransformUnknown + +skewYParser :: Parser Transformation +skewYParser = do + args <- functionParser "skewY" + return $ case args of + [x] -> SkewY x + _ -> TransformUnknown + + +scaleParser :: Parser Transformation +scaleParser = do + args <- functionParser "scale" + return $ case args of + [x] -> Scale x Nothing + [x, y] -> Scale x (Just y) + _ -> TransformUnknown + +matrixParser :: Parser Transformation +matrixParser = do + args <- functionParser "matrix" + return $ case args of + [a, b, c, d, e, f] -> + TransformMatrix a b c d e f + _ -> TransformUnknown + +rotateParser :: Parser Transformation +rotateParser = do + args <- functionParser "rotate" + return $ case args of + [angle] -> Rotate angle Nothing + [angle, x, y] -> Rotate angle $ Just (x, y) + _ -> TransformUnknown +{- +rotate( [ ]), which specifies a rotation by degrees about a given point. + +If optional parameters and are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0]. + +If optional parameters and are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(, ) rotate() translate(-, -). + +skewX(), which specifies a skew transformation along the x-axis. + +skewY(), which specifies a skew transformation along the y-axis. + -} diff --git a/src/Graphics/Svg/XmlParser.hs b/src/Graphics/Svg/XmlParser.hs --- a/src/Graphics/Svg/XmlParser.hs +++ b/src/Graphics/Svg/XmlParser.hs @@ -1,1077 +1,1077 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -module Graphics.Svg.XmlParser( xmlOfDocument - , unparseDocument - - , SvgAttributeLens( .. ) - , drawAttributesList - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Foldable( foldMap ) -import Data.Monoid( mempty ) -#endif - -import Control.Applicative( (<$>), (<$), (<|>), many ) - -import Control.Lens hiding( transform, children, elements, element ) -import Control.Monad.State.Strict( State, runState, modify, gets ) -import Data.Maybe( catMaybes ) -import Data.Monoid( Last( Last ), getLast, (<>) ) -import Data.List( foldl', intercalate ) -import Text.XML.Light.Proc( findAttrBy, elChildren, strContent ) -import Text.Read( readMaybe ) -import qualified Text.XML.Light as X -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TB -import qualified Data.Map as M -import Data.Attoparsec.Text( Parser, string, parseOnly, many1 ) -import Codec.Picture( PixelRGBA8( .. ) ) -import Graphics.Svg.Types -import Graphics.Svg.PathParser -import Graphics.Svg.ColorParser -import Graphics.Svg.CssTypes( CssDeclaration( .. ) - , CssElement( .. ) - , CssRule - , tserialize - ) -import Graphics.Svg.CssParser( complexNumber - , num - , ruleSet - , dashArray - , styleString - , numberList ) - -import Text.Printf( printf ) - -{-import Debug.Trace-} - -nodeName :: X.Element -> String -nodeName = X.qName . X.elName - -attributeFinder :: String -> X.Element -> Maybe String -attributeFinder str = - findAttrBy (\a -> X.qName a == str) - --- | Helper class to help simplify parsing code --- for various attributes. -class ParseableAttribute a where - aparse :: String -> Maybe a - aserialize :: a -> Maybe String - -instance ParseableAttribute v => ParseableAttribute (Maybe v) where - aparse = fmap Just . aparse - aserialize = (>>= aserialize) - -instance ParseableAttribute v => ParseableAttribute (Last v) where - aparse = fmap Last . aparse - aserialize = aserialize . getLast - -instance ParseableAttribute String where - aparse = Just - aserialize = Just - -instance ParseableAttribute Number where - aparse = parseMayStartDot complexNumber - aserialize = Just . serializeNumber - -instance ParseableAttribute [Number] where - aparse = parse dashArray - aserialize = Just . serializeDashArray - -instance ParseableAttribute PixelRGBA8 where - aparse = parse colorParser - aserialize = Just . colorSerializer - -instance ParseableAttribute [PathCommand] where - aparse = parse $ many1 command - aserialize = Just . serializeCommands - -instance ParseableAttribute [RPoint] where - aparse = parse pointData - aserialize = Just . serializePoints - -instance ParseableAttribute Float where - aparse = parseMayStartDot num - aserialize v = Just $ printf "%g" v - -instance ParseableAttribute Texture where - aparse = parse textureParser - aserialize = Just . textureSerializer - -instance ParseableAttribute [Transformation] where - aparse = parse $ many transformParser - aserialize = Just . serializeTransformations - -instance ParseableAttribute Cap where - aparse s = case s of - "butt" -> Just CapButt - "round" -> Just CapRound - "square" -> Just CapSquare - _ -> Nothing - - aserialize c = Just $ case c of - CapButt -> "butt" - CapRound -> "round" - CapSquare -> "square" - -instance ParseableAttribute TextAnchor where - aparse s = case s of - "middle" -> Just TextAnchorMiddle - "start" -> Just TextAnchorStart - "end" -> Just TextAnchorEnd - _ -> Nothing - - aserialize t = Just $ case t of - TextAnchorMiddle -> "middle" - TextAnchorStart -> "start" - TextAnchorEnd -> "end" - -instance ParseableAttribute ElementRef where - aparse s = case parseOnly pa $ T.pack s of - Left _ -> Nothing - Right v -> Just v - where - pa = (RefNone <$ string "none") - <|> (Ref <$> urlRef) - - aserialize c = Just $ case c of - Ref r -> "url(#" <> r <> ")" - RefNone -> "none" - -instance ParseableAttribute LineJoin where - aparse s = case s of - "miter" -> Just JoinMiter - "round" -> Just JoinRound - "bevel" -> Just JoinBevel - _ -> Nothing - - aserialize j = Just $ case j of - JoinMiter -> "miter" - JoinRound -> "round" - JoinBevel -> "bevel" - -instance ParseableAttribute CoordinateUnits where - aparse s = case s of - "userSpaceOnUse" -> Just CoordUserSpace - "objectBoundingBox" -> Just CoordBoundingBox - _ -> Just CoordBoundingBox - - aserialize uni = Just $ case uni of - CoordUserSpace -> "userSpaceOnUse" - CoordBoundingBox -> "objectBoundingBox" - -instance ParseableAttribute Spread where - aparse s = case s of - "pad" -> Just SpreadPad - "reflect" -> Just SpreadReflect - "repeat" -> Just SpreadRepeat - _ -> Nothing - - aserialize s = Just $ case s of - SpreadPad -> "pad" - SpreadReflect -> "reflect" - SpreadRepeat -> "repeat" - -instance ParseableAttribute FillRule where - aparse s = case s of - "nonzero" -> Just FillNonZero - "evenodd" -> Just FillEvenOdd - _ -> Nothing - - aserialize f = Just $ case f of - FillNonZero -> "nonzero" - FillEvenOdd -> "evenodd" - -instance ParseableAttribute TextAdjust where - aparse s = Just $ case s of - "spacing" -> TextAdjustSpacing - "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs - _ -> TextAdjustSpacing - - aserialize a = Just $ case a of - TextAdjustSpacing -> "spacing" - TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs" - -instance ParseableAttribute MarkerUnit where - aparse s = case s of - "strokeWidth" -> Just MarkerUnitStrokeWidth - "userSpaceOnUse" -> Just MarkerUnitUserSpaceOnUse - _ -> Nothing - - aserialize u = Just $ case u of - MarkerUnitStrokeWidth -> "strokeWidth" - MarkerUnitUserSpaceOnUse -> "userSpaceOnUse" - -instance ParseableAttribute MarkerOrientation where - aparse s = case (s, readMaybe s) of - ("auto", _) -> Just OrientationAuto - (_, Just f) -> Just $ OrientationAngle f - _ -> Nothing - - aserialize s = Just $ case s of - OrientationAuto -> "auto" - OrientationAngle f -> show f - -instance ParseableAttribute (Int, Int, Int, Int) where - aparse = parse viewBoxParser - aserialize = Just . serializeViewBox - -instance ParseableAttribute TextPathMethod where - aparse s = case s of - "align" -> Just TextPathAlign - "stretch" -> Just TextPathStretch - _ -> Nothing - aserialize m = Just $ case m of - TextPathAlign -> "align" - TextPathStretch -> "stretch" - -instance ParseableAttribute TextPathSpacing where - aparse s = case s of - "auto" -> Just TextPathSpacingAuto - "exact" -> Just TextPathSpacingExact - _ -> Nothing - - aserialize s = Just $ case s of - TextPathSpacingAuto -> "auto" - TextPathSpacingExact -> "exact" - -parse :: Parser a -> String -> Maybe a -parse p str = case parseOnly p (T.pack str) of - Left _ -> Nothing - Right r -> Just r - -parseMayStartDot :: Parser a -> String -> Maybe a -parseMayStartDot p l@('.':_) = parse p ('0':l) -parseMayStartDot p l = parse p l - -xmlUpdate :: (XMLUpdatable a) => a -> X.Element -> a -xmlUpdate initial el = foldl' grab initial attributes - where - grab value updater = - case attributeFinder (_attributeName updater) el of - Nothing -> value - Just v -> _attributeUpdater updater value v - -xmlUnparse :: (XMLUpdatable a) => X.Element -> a -xmlUnparse = xmlUpdate defaultSvg - -xmlUnparseWithDrawAttr - :: (XMLUpdatable a, WithDrawAttributes a) - => X.Element -> a -xmlUnparseWithDrawAttr e = - xmlUnparse e & drawAttr .~ xmlUnparse e - -data SvgAttributeLens t = SvgAttributeLens - { _attributeName :: String - , _attributeUpdater :: t -> String -> t - , _attributeSerializer :: t -> Maybe String - } - -class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where - xmlTagName :: treeNode -> String - attributes :: [SvgAttributeLens treeNode] - - serializeTreeNode :: treeNode -> X.Element - -setChildren :: X.Element -> [X.Content] -> X.Element -setChildren xNode children = xNode { X.elContent = children } - -updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> X.Element -> X.Element -updateWithAccessor accessor node xNode = - setChildren xNode $ X.Elem . serializeTreeNode <$> accessor node - -genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> X.Element -genericSerializeNode node = - X.unode (xmlTagName node) $ concatMap generateAttribute attributes - where - generateAttribute attr = case _attributeSerializer attr node of - Nothing -> [] - Just str -> return X.Attr - { X.attrKey = xName $ _attributeName attr - , X.attrVal = str - } - where - xName "href" = - X.QName { X.qName = "href" - , X.qURI = Nothing - , X.qPrefix = Just "xlink" } - xName h = X.unqual h - - -mergeAttributes :: X.Element -> X.Element -> X.Element -mergeAttributes thisXml otherXml = - thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml } - -genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode) - => treeNode -> X.Element -genericSerializeWithDrawAttr node = mergeAttributes thisXml drawAttrNode where - thisXml = genericSerializeNode node - drawAttrNode = genericSerializeNode $ node ^. drawAttr - -type CssUpdater = - DrawAttributes -> [[CssElement]] -> DrawAttributes - -groupOpacitySetter :: SvgAttributeLens DrawAttributes -groupOpacitySetter = SvgAttributeLens "opacity" updater serializer - where - updater el str = case parseMayStartDot num str of - Nothing -> el - Just v -> (el & fillOpacity .~ Just v) & strokeOpacity .~ Just v - - serializer a = case (a ^. fillOpacity, a ^. strokeOpacity) of - (Just v, Just b) | v == b -> Just $ printf "%g" v - _ -> Nothing - -opacitySetter :: String -> Lens' a (Maybe Float) -> Lens' a (Maybe Float) - -> SvgAttributeLens a -opacitySetter attribute elLens otherLens = - SvgAttributeLens attribute updater serializer - where - updater el str = case parseMayStartDot num str of - Nothing -> el - Just v -> el & elLens .~ Just v - - serializer a = case (a ^. elLens, a ^. otherLens) of - (Just v, Just b) | v == b -> Nothing - (Just v, _) -> Just $ printf "%g" v - (Nothing, _) -> Nothing - -type Serializer e = e -> Maybe String - -parserSetter :: String -> Lens' a e -> (String -> Maybe e) -> Serializer e - -> SvgAttributeLens a -parserSetter attribute elLens parser serialize = - SvgAttributeLens attribute updater serializer - where - updater el str = case parser str of - Nothing -> el - Just v -> el & elLens .~ v - - serializer a = serialize $ a ^. elLens - -parseIn :: (Eq a, WithDefaultSvg s, ParseableAttribute a) - => String -> Lens' s a -> SvgAttributeLens s -parseIn attribute elLens = - SvgAttributeLens attribute updater serializer - where - updater el str = case aparse str of - Nothing -> el - Just v -> el & elLens .~ v - - serializer a - | v /= defaultVal = aserialize v - | otherwise = Nothing - where - v = a ^. elLens - defaultVal = defaultSvg ^. elLens - -parserLastSetter :: String -> Lens' a (Last e) -> (String -> Maybe e) -> Serializer e - -> SvgAttributeLens a -parserLastSetter attribute elLens parser serialize = - SvgAttributeLens attribute updater serializer - where - updater el str = case parser str of - Nothing -> el - Just v -> el & elLens .~ Last (Just v) - - serializer a = getLast (a ^. elLens) >>= serialize - -classSetter :: SvgAttributeLens DrawAttributes -classSetter = SvgAttributeLens "class" updater serializer - where - updater el str = - el & attrClass .~ (T.split (== ' ') $ T.pack str) - - serializer a = - Just . T.unpack . T.intercalate " " $ a ^. attrClass - -cssUniqueNumber :: ASetter DrawAttributes DrawAttributes - a (Last Number) - -> CssUpdater -cssUniqueNumber setter attr ((CssNumber n:_):_) = - attr & setter .~ Last (Just n) -cssUniqueNumber _ attr _ = attr - -cssUniqueFloat :: ASetter DrawAttributes DrawAttributes a (Maybe Float) - -> CssUpdater -cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = - attr & setter .~ Just n -cssUniqueFloat _ attr _ = attr - -cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Float) - -> CssUpdater -cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) = - attr & setter .~ Last (Just n) -cssUniqueMayFloat _ attr _ = attr - -cssIdentAttr :: ParseableAttribute a => Lens' DrawAttributes a -> CssUpdater -cssIdentAttr setter attr ((CssIdent i:_):_) = case aparse $ T.unpack i of - Nothing -> attr - Just v -> attr & setter .~ v -cssIdentAttr _ attr _ = attr - -fontFamilyParser :: CssUpdater -fontFamilyParser attr (lst:_) = attr & fontFamily .~ fontNames - where - fontNames = Last . Just $ T.unpack <$> extractString lst - - extractString [] = [] - extractString (CssIdent n:rest) = n : extractString rest - extractString (CssString n:rest) = n : extractString rest - extractString (_:rest) = extractString rest -fontFamilyParser attr _ = attr - - -cssUniqueTexture :: ASetter DrawAttributes DrawAttributes - a (Last Texture) - -> CssUpdater -cssUniqueTexture setter attr ((CssIdent "none":_):_) = - attr & setter .~ Last (Just FillNone) -cssUniqueTexture setter attr ((CssColor c:_):_) = - attr & setter .~ Last (Just $ ColorRef c) -cssUniqueTexture setter attr ((CssFunction "url" [CssReference c]:_):_) = - attr & setter .~ Last (Just . TextureRef $ T.unpack c) -cssUniqueTexture _ attr _ = attr - -cssElementRefSetter :: Lens' DrawAttributes (Last ElementRef) - -> CssUpdater -cssElementRefSetter setter attr ((CssFunction "url" [CssReference c]:_):_) = - attr & setter .~ Last (Just . Ref $ T.unpack c) -cssElementRefSetter setter attr ((CssIdent "none":_):_) = - attr & setter .~ Last (Just RefNone) -cssElementRefSetter _ attr _ = attr - -cssMayStringSetter :: ASetter DrawAttributes DrawAttributes a (Maybe String) - -> CssUpdater -cssMayStringSetter setter attr ((CssIdent i:_):_) = - attr & setter .~ Just (T.unpack i) -cssMayStringSetter setter attr ((CssString i:_):_) = - attr & setter .~ Just (T.unpack i) -cssMayStringSetter _ attr _ = attr - -cssNullSetter :: CssUpdater -cssNullSetter attr _ = attr - -cssDashArray :: ASetter DrawAttributes DrawAttributes a (Last [Number]) - -> CssUpdater -cssDashArray setter attr (lst:_) = - case [n | CssNumber n <- lst ] of - [] -> attr - v -> attr & setter .~ Last (Just v) -cssDashArray _ attr _ = attr - - -drawAttributesList :: [(SvgAttributeLens DrawAttributes, CssUpdater)] -drawAttributesList = - [("stroke-width" `parseIn` strokeWidth, cssUniqueNumber strokeWidth) - ,("stroke" `parseIn` strokeColor, cssUniqueTexture strokeColor) - ,("fill" `parseIn` fillColor, cssUniqueTexture fillColor) - ,("stroke-linecap" `parseIn` strokeLineCap, cssIdentAttr strokeLineCap) - ,("stroke-linejoin" `parseIn` strokeLineJoin, cssIdentAttr strokeLineJoin) - ,("stroke-miterlimit" `parseIn` strokeMiterLimit, - cssUniqueMayFloat strokeMiterLimit) - - ,("transform" `parseIn` transform, const) - ,(groupOpacitySetter, cssUniqueFloat fillOpacity) - ,(opacitySetter "fill-opacity" fillOpacity strokeOpacity, - cssUniqueFloat fillOpacity) - ,(opacitySetter "stroke-opacity" strokeOpacity fillOpacity, - cssUniqueFloat strokeOpacity) - ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize) - ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate) - (Just . intercalate ", "), fontFamilyParser) - - ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule) - ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule) - ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef) - ,(classSetter, cssNullSetter) -- can't set class in CSS - ,("id" `parseIn` attrId, cssMayStringSetter attrId) - ,("stroke-dashoffset" `parseIn` strokeOffset, - cssUniqueNumber strokeOffset) - ,("stroke-dasharray" `parseIn` strokeDashArray, cssDashArray strokeDashArray) - ,("text-anchor" `parseIn` textAnchor, cssIdentAttr textAnchor) - ,("clip-path" `parseIn` clipPathRef, cssElementRefSetter clipPathRef) - ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd) - ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart) - ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid) - ] - where - commaSeparate = - fmap (T.unpack . T.strip) . T.split (',' ==) . T.pack - -serializeDashArray :: [Number] -> String -serializeDashArray = - intercalate ", " . fmap serializeNumber - -instance XMLUpdatable DrawAttributes where - xmlTagName _ = "DRAWATTRIBUTES" - attributes = styleAttribute : fmap fst drawAttributesList - serializeTreeNode = genericSerializeNode - -styleAttribute :: SvgAttributeLens DrawAttributes -styleAttribute = SvgAttributeLens - { _attributeName = "style" - , _attributeUpdater = updater - , _attributeSerializer = const Nothing - } - where - updater attrs style = case parse styleString style of - Nothing -> attrs - Just decls -> foldl' applyer attrs decls - - cssUpdaters = [(T.pack $ _attributeName n, u) | (n, u) <- drawAttributesList] - applyer value (CssDeclaration txt elems) = - case lookup txt cssUpdaters of - Nothing -> value - Just f -> f value elems - -instance XMLUpdatable Rectangle where - xmlTagName _ = "rect" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = - ["width" `parseIn` rectWidth - ,"height" `parseIn` rectHeight - ,"x" `parseIn` (rectUpperLeftCorner._1) - ,"y" `parseIn` (rectUpperLeftCorner._2) - ,"rx" `parseIn` (rectCornerRadius._1) - ,"ry" `parseIn` (rectCornerRadius._2) - ] - -instance XMLUpdatable Image where - xmlTagName _ = "image" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = - ["width" `parseIn` imageWidth - ,"height" `parseIn` imageHeight - ,"x" `parseIn` (imageCornerUpperLeft._1) - ,"y" `parseIn` (imageCornerUpperLeft._2) - ,parserSetter "href" imageHref (Just . dropSharp) (Just . ('#':)) - ] - -instance XMLUpdatable Line where - xmlTagName _ = "line" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = - ["x1" `parseIn` (linePoint1._1) - ,"y1" `parseIn` (linePoint1._2) - ,"x2" `parseIn` (linePoint2._1) - ,"y2" `parseIn` (linePoint2._2) - ] - -instance XMLUpdatable Ellipse where - xmlTagName _ = "ellipse" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = - ["cx" `parseIn` (ellipseCenter._1) - ,"cy" `parseIn` (ellipseCenter._2) - ,"rx" `parseIn` ellipseXRadius - ,"ry" `parseIn` ellipseYRadius - ] - -instance XMLUpdatable Circle where - xmlTagName _ = "circle" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = - ["cx" `parseIn` (circleCenter._1) - ,"cy" `parseIn` (circleCenter._2) - ,"r" `parseIn` circleRadius - ] - -instance XMLUpdatable Mask where - xmlTagName _ = "mask" - serializeTreeNode node = - updateWithAccessor _maskContent node $ - genericSerializeWithDrawAttr node - - attributes = - ["x" `parseIn` (maskPosition._1) - ,"y" `parseIn` (maskPosition._2) - ,"width" `parseIn` maskWidth - ,"height" `parseIn` maskHeight - ,"maskContentUnits" `parseIn` maskContentUnits - ,"maskUnits" `parseIn` maskUnits - ] - -instance XMLUpdatable ClipPath where - xmlTagName _ = "clipPath" - serializeTreeNode node = - updateWithAccessor _clipPathContent node $ - genericSerializeWithDrawAttr node - attributes = - ["clipPathUnits" `parseIn` clipPathUnits] - -instance XMLUpdatable Polygon where - xmlTagName _ = "polygon" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = ["points" `parseIn` polygonPoints] - -instance XMLUpdatable PolyLine where - xmlTagName _ = "polyline" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = ["points" `parseIn` polyLinePoints] - -instance XMLUpdatable Path where - xmlTagName _ = "path" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = ["d" `parseIn` pathDefinition] - -instance XMLUpdatable LinearGradient where - xmlTagName _ = "linearGradient" - serializeTreeNode node = - updateWithAccessor _linearGradientStops node $ genericSerializeNode node - - attributes = - ["gradientTransform" `parseIn` linearGradientTransform - ,"gradientUnits" `parseIn` linearGradientUnits - ,"spreadMethod" `parseIn` linearGradientSpread - ,"x1" `parseIn` (linearGradientStart._1) - ,"y1" `parseIn` (linearGradientStart._2) - ,"x2" `parseIn` (linearGradientStop._1) - ,"y2" `parseIn` (linearGradientStop._2) - ] - -instance XMLUpdatable Tree where - xmlTagName _ = "TREE" - attributes = [] - serializeTreeNode e = case e of - None -> X.blank_element - UseTree u _ -> serializeTreeNode u - GroupTree g -> serializeTreeNode g - SymbolTree s -> serializeTreeNode s - PathTree p -> serializeTreeNode p - CircleTree c -> serializeTreeNode c - PolyLineTree p -> serializeTreeNode p - PolygonTree p -> serializeTreeNode p - EllipseTree el -> serializeTreeNode el - LineTree l -> serializeTreeNode l - RectangleTree r -> serializeTreeNode r - TextTree Nothing t -> serializeTreeNode t - ImageTree i -> serializeTreeNode i - TextTree (Just p) t -> - setChildren textNode [X.Elem . setChildren pathNode $ X.elContent textNode] - where - textNode = serializeTreeNode t - pathNode = serializeTreeNode p - - -isNotNone :: Tree -> Bool -isNotNone None = False -isNotNone _ = True - -instance XMLUpdatable (Group Tree) where - xmlTagName _ = "g" - serializeTreeNode node = - updateWithAccessor (filter isNotNone . _groupChildren) node $ - genericSerializeWithDrawAttr node - attributes = [] - -instance XMLUpdatable (Symbol Tree) where - xmlTagName _ = "symbol" - serializeTreeNode node = - updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $ - genericSerializeWithDrawAttr node - attributes = - ["viewBox" `parseIn` (groupOfSymbol . groupViewBox)] - - -instance XMLUpdatable RadialGradient where - xmlTagName _ = "radialGradient" - serializeTreeNode node = - updateWithAccessor _radialGradientStops node $ genericSerializeNode node - attributes = - ["gradientTransform" `parseIn` radialGradientTransform - ,"gradientUnits" `parseIn` radialGradientUnits - ,"spreadMethod" `parseIn` radialGradientSpread - ,"cx" `parseIn` (radialGradientCenter._1) - ,"cy" `parseIn` (radialGradientCenter._2) - ,"r" `parseIn` radialGradientRadius - ,"fx" `parseIn` radialGradientFocusX - ,"fy" `parseIn` radialGradientFocusY - ] - -instance XMLUpdatable Use where - xmlTagName _ = "use" - serializeTreeNode = genericSerializeWithDrawAttr - attributes = - ["x" `parseIn` (useBase._1) - ,"y" `parseIn` (useBase._2) - ,"width" `parseIn` useWidth - ,"height" `parseIn` useHeight - ,parserSetter "href" useName (Just . dropSharp) (Just . ('#':)) - ] - -dropSharp :: String -> String -dropSharp ('#':rest) = rest -dropSharp a = a - -instance XMLUpdatable TextInfo where - xmlTagName _ = "tspan" - serializeTreeNode = genericSerializeNode - attributes = - [parserSetter "x" textInfoX (parse dashArray) dashNotEmpty - ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty - ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty - ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty - ,parserSetter "rotate" textInfoRotate - (parse numberList) - rotateNotEmpty - ,"textLength" `parseIn` textInfoLength - ] - where - dashNotEmpty [] = Nothing - dashNotEmpty lst = Just $ serializeDashArray lst - - rotateNotEmpty [] = Nothing - rotateNotEmpty lst = - Just . unwords $ printf "%g" <$> lst - - -instance XMLUpdatable TextPath where - xmlTagName _ = "textPath" - serializeTreeNode = genericSerializeNode - attributes = - ["startOffset" `parseIn` textPathStartOffset - ,"method" `parseIn` textPathMethod - ,"spacing" `parseIn` textPathSpacing - ,parserSetter "href" textPathName (Just . dropSharp) (Just . ('#':)) - ] - -instance XMLUpdatable Text where - xmlTagName _ = "text" - serializeTreeNode = serializeText - attributes = ["lengthAdjust" `parseIn` textAdjust] - - -instance XMLUpdatable Pattern where - xmlTagName _ = "pattern" - serializeTreeNode node = - updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node - attributes = - ["viewBox" `parseIn` patternViewBox - ,"patternUnits" `parseIn` patternUnit - ,"width" `parseIn` patternWidth - ,"height" `parseIn` patternHeight - ,"x" `parseIn` (patternPos._1) - ,"y" `parseIn` (patternPos._2) - ] - -instance XMLUpdatable Marker where - xmlTagName _ = "marker" - serializeTreeNode node = - updateWithAccessor _markerElements node $ genericSerializeWithDrawAttr node - attributes = - ["refX" `parseIn` (markerRefPoint._1) - ,"refY" `parseIn` (markerRefPoint._2) - ,"markerWidth" `parseIn` markerWidth - ,"markerHeight" `parseIn` markerHeight - ,"patternUnits" `parseIn` markerUnits - ,"orient" `parseIn` markerOrient - ,"viewBox" `parseIn` markerViewBox - ] - -serializeText :: Text -> X.Element -serializeText topText = topNode { X.elName = X.unqual "text" } where - topNode = serializeSpan $ _textRoot topText - - serializeSpan tspan = setChildren (mergeAttributes info drawInfo) subContent - where - info = genericSerializeNode $ _spanInfo tspan - drawInfo = genericSerializeNode $ _spanDrawAttributes tspan - subContent = serializeContent <$> _spanContent tspan - - serializeContent (SpanText t) = X.Text $ X.blank_cdata { X.cdData = T.unpack t } - serializeContent (SpanTextRef _t) = X.Text $ X.blank_cdata { X.cdData = "" } - serializeContent (SpanSub sub) = X.Elem $ serializeSpan sub - -unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath) -unparseText = extractResult . go True - where - extractResult (a, b, _) = (a, b) - - go startStrip [] = ([], Nothing, startStrip) - go startStrip (X.CRef _:rest) = go startStrip rest - go startStrip (X.Elem e@(nodeName -> "tspan"):rest) = - (SpanSub spans : trest, mpath, retStrip) - where - (trest, mpath, retStrip) = go restStrip rest - (sub, _, restStrip) = go startStrip $ X.elContent e - spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub - - go startStrip (X.Elem e@(nodeName -> "tref"):rest) = - case attributeFinder "href" e of - Nothing -> go startStrip rest - Just v -> (SpanTextRef v : trest, mpath, stripRet) - where (trest, mpath, stripRet) = go startStrip rest - - go startStrip (X.Elem e@(nodeName -> "textPath"):rest) = - case attributeFinder "href" e of - Nothing -> go startStrip rest - Just v -> (tsub ++ trest, pure p, retStrp) - where - p = (xmlUnparse e) { _textPathName = dropSharp v } - (trest, _, retStrp) = go restStrip rest - (tsub, _, restStrip) = go startStrip $ X.elContent e - - go startStrip (X.Elem _:rest) = go startStrip rest - go startStrip (X.Text t:rest) - | T.length cleanText == 0 = go startStrip rest - | otherwise = - (SpanText cleanText : trest, mpath, stripRet) - where - (trest, mpath, stripRet) = go subShouldStrip rest - - subShouldStrip = T.pack " " `T.isSuffixOf` cleanText - - space = T.singleton ' ' - singulariseSpaces tt - | space `T.isPrefixOf` tt = space - | otherwise = tt - - stripStart | startStrip = T.stripStart - | otherwise = id - - cleanText = stripStart - . T.concat - . fmap singulariseSpaces - . T.groupBy (\a b -> (a /= ' ' && b /= ' ') || a == b) - . T.filter (\c -> c /= '\n' && c /= '\r') - . T.map (\c -> if c == '\t' then ' ' else c) - . T.pack - $ X.cdData t - -gradientOffsetSetter :: SvgAttributeLens GradientStop -gradientOffsetSetter = SvgAttributeLens "offset" setter serialize - where - serialize a = Just $ printf "%d%%" percentage - where percentage = floor . (100 *) $ a ^. gradientOffset :: Int - - setter el str = el & gradientOffset .~ val - where - val = case parseMayStartDot complexNumber str of - Nothing -> 0 - Just (Num n) -> n - Just (Px n) -> n - Just (Percent n) -> n - Just (Em n) -> n - Just (Pc n) -> n - Just (Mm n) -> n - Just (Cm n) -> n - Just (Point n) -> n - Just (Inches n) -> n - -instance XMLUpdatable GradientStop where - xmlTagName _ = "stop" - serializeTreeNode = genericSerializeNode - attributes = - [gradientOffsetSetter - ,"stop-color" `parseIn` gradientColor - ] - - -data Symbols = Symbols - { symbols :: !(M.Map String Element) - , cssStyle :: [CssRule] - } - -emptyState :: Symbols -emptyState = Symbols mempty mempty - -parseGradientStops :: X.Element -> [GradientStop] -parseGradientStops = concatMap unStop . elChildren - where - unStop e@(nodeName -> "stop") = [xmlUnparse e] - unStop _ = [] - -withId :: X.Element -> (X.Element -> Element) - -> State Symbols Tree -withId el f = case attributeFinder "id" el of - Nothing -> return None - Just elemId -> do - modify $ \s -> - s { symbols = M.insert elemId (f el) $ symbols s } - return None - -unparseDefs :: X.Element -> State Symbols Tree -unparseDefs e@(nodeName -> "pattern") = do - subElements <- mapM unparse $ elChildren e - withId e . const . ElementPattern $ pat { _patternElements = subElements} - where - pat = xmlUnparse e -unparseDefs e@(nodeName -> "marker") = do - subElements <- mapM unparse $ elChildren e - withId e . const . ElementMarker $ mark {_markerElements = subElements } - where - mark = xmlUnparseWithDrawAttr e -unparseDefs e@(nodeName -> "mask") = do - children <- mapM unparse $ elChildren e - let realChildren = filter isNotNone children - parsedMask = xmlUnparseWithDrawAttr e - withId e . const . ElementMask $ parsedMask { _maskContent = realChildren } - -unparseDefs e@(nodeName -> "clipPath") = do - children <- mapM unparse $ elChildren e - let realChildren = filter isNotNone children - parsedClip = xmlUnparseWithDrawAttr e - withId e . const . ElementClipPath $ parsedClip { _clipPathContent = realChildren } - -unparseDefs e@(nodeName -> "linearGradient") = - withId e $ ElementLinearGradient . unparser - where - unparser ee = - xmlUnparse ee & linearGradientStops .~ parseGradientStops ee -unparseDefs e@(nodeName -> "radialGradient") = - withId e $ ElementRadialGradient . unparser - where - unparser ee = - xmlUnparse ee & radialGradientStops .~ parseGradientStops ee -unparseDefs e = do - el <- unparse e - withId e (const $ ElementGeometry el) - -unparse :: X.Element -> State Symbols Tree -unparse e@(nodeName -> "style") = do - case parseOnly (many1 ruleSet) . T.pack $ strContent e of - Left _ -> return () - Right rules -> - modify $ \s -> s { cssStyle = cssStyle s ++ rules } - return None -unparse e@(nodeName -> "defs") = do - mapM_ unparseDefs $ elChildren e - return None -unparse e@(nodeName -> "symbol") = do - symbolChildren <- mapM unparse $ elChildren e - let realChildren = filter isNotNone symbolChildren - pure . SymbolTree . Symbol $ groupNode & groupChildren .~ realChildren - where - groupNode :: Group Tree - groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e - -unparse e@(nodeName -> "g") = do - children <- mapM unparse $ elChildren e - let realChildren = filter isNotNone children - - groupNode :: Group Tree - groupNode = xmlUnparseWithDrawAttr e - - pure $ GroupTree $ groupNode & groupChildren .~ realChildren - -unparse e@(nodeName -> "text") = do - pathWithGeometry <- pathGeomtryOf tPath - pure . TextTree pathWithGeometry $ xmlUnparse e & textRoot .~ root - where - (textContent, tPath) = unparseText $ X.elContent e - - pathGeomtryOf Nothing = pure Nothing - pathGeomtryOf (Just pathInfo) = do - pathElem <- gets $ M.lookup (_textPathName pathInfo) . symbols - case pathElem of - Nothing -> pure Nothing - Just (ElementLinearGradient _) -> pure Nothing - Just (ElementRadialGradient _) -> pure Nothing - Just (ElementPattern _) -> pure Nothing - Just (ElementMask _) -> pure Nothing - Just (ElementClipPath _) -> pure Nothing - Just (ElementMarker _) -> pure Nothing - Just (ElementGeometry (PathTree p)) -> - pure . Just $ pathInfo { _textPathData = _pathDefinition p } - Just (ElementGeometry _) -> pure Nothing - - root = TextSpan - { _spanInfo = xmlUnparse e - , _spanDrawAttributes = xmlUnparse e - , _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 - "use" -> UseTree parsed Nothing - _ -> None - where - parsed :: (XMLUpdatable a, WithDrawAttributes a) => a - parsed = xmlUnparseWithDrawAttr e - -unparseDocument :: FilePath -> X.Element -> Maybe Document -unparseDocument rootLocation e@(nodeName -> "svg") = Just Document - { _viewBox = - attributeFinder "viewBox" e >>= parse viewBoxParser - , _elements = parsedElements - , _width = lengthFind "width" - , _height = lengthFind "height" - , _definitions = symbols named - , _description = "" - , _styleRules = cssStyle named - , _documentLocation = rootLocation - } - where - (parsedElements, named) = - runState (mapM unparse $ elChildren e) emptyState - lengthFind n = - attributeFinder n e >>= parse complexNumber -unparseDocument _ _ = Nothing - --- | Transform a SVG document to a XML node. -xmlOfDocument :: Document -> X.Element -xmlOfDocument doc = - X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ defsTag ++ children) - where - attr name = X.Attr (X.unqual name) - children = [serializeTreeNode el | el <- _elements doc, isNotNone el ] - - defsTag | null defs = [] - | otherwise = [X.node (X.unqual "defs") defs] - - defs = [elementRender k e | (k, e) <- M.assocs $ _definitions doc - , isElementNotNone e] - - isElementNotNone (ElementGeometry el) = isNotNone el - isElementNotNone _ = True - - elementRender k e = case e of - ElementGeometry t -> serializeTreeNode t - ElementMarker m -> serializeTreeNode m - ElementMask m -> serializeTreeNode m - ElementClipPath c -> serializeTreeNode c - ElementPattern p -> - X.add_attr (attr "id" k) $ serializeTreeNode p - ElementLinearGradient lg -> - X.add_attr (attr "id" k) $ serializeTreeNode lg - ElementRadialGradient rg -> - X.add_attr (attr "id" k) $ serializeTreeNode rg - - docViewBox = case _viewBox doc of - Nothing -> [] - Just b -> [attr "viewBox" $ serializeViewBox b] - - descTag = case _description doc of - "" -> [] - txt -> [X.node (X.unqual "desc") txt] - - styleTag = case _styleRules doc of - [] -> [] - rules -> [X.node (X.unqual "style") - ([attr "type" "text/css"], txt)] - where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules - - attrs = - docViewBox ++ - [attr "xmlns" "http://www.w3.org/2000/svg" - ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink" - ,attr "version" "1.1"] ++ - catMaybes [attr "width" . serializeNumber <$> _width doc - ,attr "height" . serializeNumber <$> _height doc - ] - +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Graphics.Svg.XmlParser( xmlOfDocument + , unparseDocument + + , SvgAttributeLens( .. ) + , drawAttributesList + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<$>), (<$) ) +import Data.Foldable( foldMap ) +import Data.Monoid( mempty ) +#endif + +import Control.Applicative( (<|>), many ) + +import Control.Lens hiding( transform, children, elements, element ) +import Control.Monad.State.Strict( State, runState, modify, gets ) +import Data.Maybe( catMaybes ) +import Data.Monoid( Last( Last ), getLast, (<>) ) +import Data.List( foldl', intercalate ) +import Text.XML.Light.Proc( findAttrBy, elChildren, strContent ) +import Text.Read( readMaybe ) +import qualified Text.XML.Light as X +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Map as M +import Data.Attoparsec.Text( Parser, string, parseOnly, many1 ) +import Codec.Picture( PixelRGBA8( .. ) ) +import Graphics.Svg.Types +import Graphics.Svg.PathParser +import Graphics.Svg.ColorParser +import Graphics.Svg.CssTypes( CssDeclaration( .. ) + , CssElement( .. ) + , CssRule + , tserialize + ) +import Graphics.Svg.CssParser( complexNumber + , num + , ruleSet + , dashArray + , styleString + , numberList ) + +import Text.Printf( printf ) + +{-import Debug.Trace-} + +nodeName :: X.Element -> String +nodeName = X.qName . X.elName + +attributeFinder :: String -> X.Element -> Maybe String +attributeFinder str = + findAttrBy (\a -> X.qName a == str) + +-- | Helper class to help simplify parsing code +-- for various attributes. +class ParseableAttribute a where + aparse :: String -> Maybe a + aserialize :: a -> Maybe String + +instance ParseableAttribute v => ParseableAttribute (Maybe v) where + aparse = fmap Just . aparse + aserialize = (>>= aserialize) + +instance ParseableAttribute v => ParseableAttribute (Last v) where + aparse = fmap Last . aparse + aserialize = aserialize . getLast + +instance ParseableAttribute String where + aparse = Just + aserialize = Just + +instance ParseableAttribute Number where + aparse = parseMayStartDot complexNumber + aserialize = Just . serializeNumber + +instance ParseableAttribute [Number] where + aparse = parse dashArray + aserialize = Just . serializeDashArray + +instance ParseableAttribute PixelRGBA8 where + aparse = parse colorParser + aserialize = Just . colorSerializer + +instance ParseableAttribute [PathCommand] where + aparse = parse $ many1 command + aserialize = Just . serializeCommands + +instance ParseableAttribute [RPoint] where + aparse = parse pointData + aserialize = Just . serializePoints + +instance ParseableAttribute Float where + aparse = parseMayStartDot num + aserialize v = Just $ printf "%g" v + +instance ParseableAttribute Texture where + aparse = parse textureParser + aserialize = Just . textureSerializer + +instance ParseableAttribute [Transformation] where + aparse = parse $ many transformParser + aserialize = Just . serializeTransformations + +instance ParseableAttribute Cap where + aparse s = case s of + "butt" -> Just CapButt + "round" -> Just CapRound + "square" -> Just CapSquare + _ -> Nothing + + aserialize c = Just $ case c of + CapButt -> "butt" + CapRound -> "round" + CapSquare -> "square" + +instance ParseableAttribute TextAnchor where + aparse s = case s of + "middle" -> Just TextAnchorMiddle + "start" -> Just TextAnchorStart + "end" -> Just TextAnchorEnd + _ -> Nothing + + aserialize t = Just $ case t of + TextAnchorMiddle -> "middle" + TextAnchorStart -> "start" + TextAnchorEnd -> "end" + +instance ParseableAttribute ElementRef where + aparse s = case parseOnly pa $ T.pack s of + Left _ -> Nothing + Right v -> Just v + where + pa = (RefNone <$ string "none") + <|> (Ref <$> urlRef) + + aserialize c = Just $ case c of + Ref r -> "url(#" <> r <> ")" + RefNone -> "none" + +instance ParseableAttribute LineJoin where + aparse s = case s of + "miter" -> Just JoinMiter + "round" -> Just JoinRound + "bevel" -> Just JoinBevel + _ -> Nothing + + aserialize j = Just $ case j of + JoinMiter -> "miter" + JoinRound -> "round" + JoinBevel -> "bevel" + +instance ParseableAttribute CoordinateUnits where + aparse s = case s of + "userSpaceOnUse" -> Just CoordUserSpace + "objectBoundingBox" -> Just CoordBoundingBox + _ -> Just CoordBoundingBox + + aserialize uni = Just $ case uni of + CoordUserSpace -> "userSpaceOnUse" + CoordBoundingBox -> "objectBoundingBox" + +instance ParseableAttribute Spread where + aparse s = case s of + "pad" -> Just SpreadPad + "reflect" -> Just SpreadReflect + "repeat" -> Just SpreadRepeat + _ -> Nothing + + aserialize s = Just $ case s of + SpreadPad -> "pad" + SpreadReflect -> "reflect" + SpreadRepeat -> "repeat" + +instance ParseableAttribute FillRule where + aparse s = case s of + "nonzero" -> Just FillNonZero + "evenodd" -> Just FillEvenOdd + _ -> Nothing + + aserialize f = Just $ case f of + FillNonZero -> "nonzero" + FillEvenOdd -> "evenodd" + +instance ParseableAttribute TextAdjust where + aparse s = Just $ case s of + "spacing" -> TextAdjustSpacing + "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs + _ -> TextAdjustSpacing + + aserialize a = Just $ case a of + TextAdjustSpacing -> "spacing" + TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs" + +instance ParseableAttribute MarkerUnit where + aparse s = case s of + "strokeWidth" -> Just MarkerUnitStrokeWidth + "userSpaceOnUse" -> Just MarkerUnitUserSpaceOnUse + _ -> Nothing + + aserialize u = Just $ case u of + MarkerUnitStrokeWidth -> "strokeWidth" + MarkerUnitUserSpaceOnUse -> "userSpaceOnUse" + +instance ParseableAttribute MarkerOrientation where + aparse s = case (s, readMaybe s) of + ("auto", _) -> Just OrientationAuto + (_, Just f) -> Just $ OrientationAngle f + _ -> Nothing + + aserialize s = Just $ case s of + OrientationAuto -> "auto" + OrientationAngle f -> show f + +instance ParseableAttribute (Int, Int, Int, Int) where + aparse = parse viewBoxParser + aserialize = Just . serializeViewBox + +instance ParseableAttribute TextPathMethod where + aparse s = case s of + "align" -> Just TextPathAlign + "stretch" -> Just TextPathStretch + _ -> Nothing + aserialize m = Just $ case m of + TextPathAlign -> "align" + TextPathStretch -> "stretch" + +instance ParseableAttribute TextPathSpacing where + aparse s = case s of + "auto" -> Just TextPathSpacingAuto + "exact" -> Just TextPathSpacingExact + _ -> Nothing + + aserialize s = Just $ case s of + TextPathSpacingAuto -> "auto" + TextPathSpacingExact -> "exact" + +parse :: Parser a -> String -> Maybe a +parse p str = case parseOnly p (T.pack str) of + Left _ -> Nothing + Right r -> Just r + +parseMayStartDot :: Parser a -> String -> Maybe a +parseMayStartDot p l@('.':_) = parse p ('0':l) +parseMayStartDot p l = parse p l + +xmlUpdate :: (XMLUpdatable a) => a -> X.Element -> a +xmlUpdate initial el = foldl' grab initial attributes + where + grab value updater = + case attributeFinder (_attributeName updater) el of + Nothing -> value + Just v -> _attributeUpdater updater value v + +xmlUnparse :: (XMLUpdatable a) => X.Element -> a +xmlUnparse = xmlUpdate defaultSvg + +xmlUnparseWithDrawAttr + :: (XMLUpdatable a, WithDrawAttributes a) + => X.Element -> a +xmlUnparseWithDrawAttr e = + xmlUnparse e & drawAttr .~ xmlUnparse e + +data SvgAttributeLens t = SvgAttributeLens + { _attributeName :: String + , _attributeUpdater :: t -> String -> t + , _attributeSerializer :: t -> Maybe String + } + +class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where + xmlTagName :: treeNode -> String + attributes :: [SvgAttributeLens treeNode] + + serializeTreeNode :: treeNode -> X.Element + +setChildren :: X.Element -> [X.Content] -> X.Element +setChildren xNode children = xNode { X.elContent = children } + +updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> X.Element -> X.Element +updateWithAccessor accessor node xNode = + setChildren xNode $ X.Elem . serializeTreeNode <$> accessor node + +genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> X.Element +genericSerializeNode node = + X.unode (xmlTagName node) $ concatMap generateAttribute attributes + where + generateAttribute attr = case _attributeSerializer attr node of + Nothing -> [] + Just str -> return X.Attr + { X.attrKey = xName $ _attributeName attr + , X.attrVal = str + } + where + xName "href" = + X.QName { X.qName = "href" + , X.qURI = Nothing + , X.qPrefix = Just "xlink" } + xName h = X.unqual h + + +mergeAttributes :: X.Element -> X.Element -> X.Element +mergeAttributes thisXml otherXml = + thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml } + +genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode) + => treeNode -> X.Element +genericSerializeWithDrawAttr node = mergeAttributes thisXml drawAttrNode where + thisXml = genericSerializeNode node + drawAttrNode = genericSerializeNode $ node ^. drawAttr + +type CssUpdater = + DrawAttributes -> [[CssElement]] -> DrawAttributes + +groupOpacitySetter :: SvgAttributeLens DrawAttributes +groupOpacitySetter = SvgAttributeLens "opacity" updater serializer + where + updater el str = case parseMayStartDot num str of + Nothing -> el + Just v -> (el & fillOpacity .~ Just v) & strokeOpacity .~ Just v + + serializer a = case (a ^. fillOpacity, a ^. strokeOpacity) of + (Just v, Just b) | v == b -> Just $ printf "%g" v + _ -> Nothing + +opacitySetter :: String -> Lens' a (Maybe Float) -> Lens' a (Maybe Float) + -> SvgAttributeLens a +opacitySetter attribute elLens otherLens = + SvgAttributeLens attribute updater serializer + where + updater el str = case parseMayStartDot num str of + Nothing -> el + Just v -> el & elLens .~ Just v + + serializer a = case (a ^. elLens, a ^. otherLens) of + (Just v, Just b) | v == b -> Nothing + (Just v, _) -> Just $ printf "%g" v + (Nothing, _) -> Nothing + +type Serializer e = e -> Maybe String + +parserSetter :: String -> Lens' a e -> (String -> Maybe e) -> Serializer e + -> SvgAttributeLens a +parserSetter attribute elLens parser serialize = + SvgAttributeLens attribute updater serializer + where + updater el str = case parser str of + Nothing -> el + Just v -> el & elLens .~ v + + serializer a = serialize $ a ^. elLens + +parseIn :: (Eq a, WithDefaultSvg s, ParseableAttribute a) + => String -> Lens' s a -> SvgAttributeLens s +parseIn attribute elLens = + SvgAttributeLens attribute updater serializer + where + updater el str = case aparse str of + Nothing -> el + Just v -> el & elLens .~ v + + serializer a + | v /= defaultVal = aserialize v + | otherwise = Nothing + where + v = a ^. elLens + defaultVal = defaultSvg ^. elLens + +parserLastSetter :: String -> Lens' a (Last e) -> (String -> Maybe e) -> Serializer e + -> SvgAttributeLens a +parserLastSetter attribute elLens parser serialize = + SvgAttributeLens attribute updater serializer + where + updater el str = case parser str of + Nothing -> el + Just v -> el & elLens .~ Last (Just v) + + serializer a = getLast (a ^. elLens) >>= serialize + +classSetter :: SvgAttributeLens DrawAttributes +classSetter = SvgAttributeLens "class" updater serializer + where + updater el str = + el & attrClass .~ (T.split (== ' ') $ T.pack str) + + serializer a = + Just . T.unpack . T.intercalate " " $ a ^. attrClass + +cssUniqueNumber :: ASetter DrawAttributes DrawAttributes + a (Last Number) + -> CssUpdater +cssUniqueNumber setter attr ((CssNumber n:_):_) = + attr & setter .~ Last (Just n) +cssUniqueNumber _ attr _ = attr + +cssUniqueFloat :: ASetter DrawAttributes DrawAttributes a (Maybe Float) + -> CssUpdater +cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = + attr & setter .~ Just n +cssUniqueFloat _ attr _ = attr + +cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Float) + -> CssUpdater +cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) = + attr & setter .~ Last (Just n) +cssUniqueMayFloat _ attr _ = attr + +cssIdentAttr :: ParseableAttribute a => Lens' DrawAttributes a -> CssUpdater +cssIdentAttr setter attr ((CssIdent i:_):_) = case aparse $ T.unpack i of + Nothing -> attr + Just v -> attr & setter .~ v +cssIdentAttr _ attr _ = attr + +fontFamilyParser :: CssUpdater +fontFamilyParser attr (lst:_) = attr & fontFamily .~ fontNames + where + fontNames = Last . Just $ T.unpack <$> extractString lst + + extractString [] = [] + extractString (CssIdent n:rest) = n : extractString rest + extractString (CssString n:rest) = n : extractString rest + extractString (_:rest) = extractString rest +fontFamilyParser attr _ = attr + + +cssUniqueTexture :: ASetter DrawAttributes DrawAttributes + a (Last Texture) + -> CssUpdater +cssUniqueTexture setter attr ((CssIdent "none":_):_) = + attr & setter .~ Last (Just FillNone) +cssUniqueTexture setter attr ((CssColor c:_):_) = + attr & setter .~ Last (Just $ ColorRef c) +cssUniqueTexture setter attr ((CssFunction "url" [CssReference c]:_):_) = + attr & setter .~ Last (Just . TextureRef $ T.unpack c) +cssUniqueTexture _ attr _ = attr + +cssElementRefSetter :: Lens' DrawAttributes (Last ElementRef) + -> CssUpdater +cssElementRefSetter setter attr ((CssFunction "url" [CssReference c]:_):_) = + attr & setter .~ Last (Just . Ref $ T.unpack c) +cssElementRefSetter setter attr ((CssIdent "none":_):_) = + attr & setter .~ Last (Just RefNone) +cssElementRefSetter _ attr _ = attr + +cssMayStringSetter :: ASetter DrawAttributes DrawAttributes a (Maybe String) + -> CssUpdater +cssMayStringSetter setter attr ((CssIdent i:_):_) = + attr & setter .~ Just (T.unpack i) +cssMayStringSetter setter attr ((CssString i:_):_) = + attr & setter .~ Just (T.unpack i) +cssMayStringSetter _ attr _ = attr + +cssNullSetter :: CssUpdater +cssNullSetter attr _ = attr + +cssDashArray :: ASetter DrawAttributes DrawAttributes a (Last [Number]) + -> CssUpdater +cssDashArray setter attr (lst:_) = + case [n | CssNumber n <- lst ] of + [] -> attr + v -> attr & setter .~ Last (Just v) +cssDashArray _ attr _ = attr + + +drawAttributesList :: [(SvgAttributeLens DrawAttributes, CssUpdater)] +drawAttributesList = + [("stroke-width" `parseIn` strokeWidth, cssUniqueNumber strokeWidth) + ,("stroke" `parseIn` strokeColor, cssUniqueTexture strokeColor) + ,("fill" `parseIn` fillColor, cssUniqueTexture fillColor) + ,("stroke-linecap" `parseIn` strokeLineCap, cssIdentAttr strokeLineCap) + ,("stroke-linejoin" `parseIn` strokeLineJoin, cssIdentAttr strokeLineJoin) + ,("stroke-miterlimit" `parseIn` strokeMiterLimit, + cssUniqueMayFloat strokeMiterLimit) + + ,("transform" `parseIn` transform, const) + ,(groupOpacitySetter, cssUniqueFloat fillOpacity) + ,(opacitySetter "fill-opacity" fillOpacity strokeOpacity, + cssUniqueFloat fillOpacity) + ,(opacitySetter "stroke-opacity" strokeOpacity fillOpacity, + cssUniqueFloat strokeOpacity) + ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize) + ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate) + (Just . intercalate ", "), fontFamilyParser) + + ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule) + ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule) + ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef) + ,(classSetter, cssNullSetter) -- can't set class in CSS + ,("id" `parseIn` attrId, cssMayStringSetter attrId) + ,("stroke-dashoffset" `parseIn` strokeOffset, + cssUniqueNumber strokeOffset) + ,("stroke-dasharray" `parseIn` strokeDashArray, cssDashArray strokeDashArray) + ,("text-anchor" `parseIn` textAnchor, cssIdentAttr textAnchor) + ,("clip-path" `parseIn` clipPathRef, cssElementRefSetter clipPathRef) + ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd) + ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart) + ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid) + ] + where + commaSeparate = + fmap (T.unpack . T.strip) . T.split (',' ==) . T.pack + +serializeDashArray :: [Number] -> String +serializeDashArray = + intercalate ", " . fmap serializeNumber + +instance XMLUpdatable DrawAttributes where + xmlTagName _ = "DRAWATTRIBUTES" + attributes = styleAttribute : fmap fst drawAttributesList + serializeTreeNode = genericSerializeNode + +styleAttribute :: SvgAttributeLens DrawAttributes +styleAttribute = SvgAttributeLens + { _attributeName = "style" + , _attributeUpdater = updater + , _attributeSerializer = const Nothing + } + where + updater attrs style = case parse styleString style of + Nothing -> attrs + Just decls -> foldl' applyer attrs decls + + cssUpdaters = [(T.pack $ _attributeName n, u) | (n, u) <- drawAttributesList] + applyer value (CssDeclaration txt elems) = + case lookup txt cssUpdaters of + Nothing -> value + Just f -> f value elems + +instance XMLUpdatable Rectangle where + xmlTagName _ = "rect" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["width" `parseIn` rectWidth + ,"height" `parseIn` rectHeight + ,"x" `parseIn` (rectUpperLeftCorner._1) + ,"y" `parseIn` (rectUpperLeftCorner._2) + ,"rx" `parseIn` (rectCornerRadius._1) + ,"ry" `parseIn` (rectCornerRadius._2) + ] + +instance XMLUpdatable Image where + xmlTagName _ = "image" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["width" `parseIn` imageWidth + ,"height" `parseIn` imageHeight + ,"x" `parseIn` (imageCornerUpperLeft._1) + ,"y" `parseIn` (imageCornerUpperLeft._2) + ,parserSetter "href" imageHref (Just . dropSharp) (Just . ('#':)) + ] + +instance XMLUpdatable Line where + xmlTagName _ = "line" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["x1" `parseIn` (linePoint1._1) + ,"y1" `parseIn` (linePoint1._2) + ,"x2" `parseIn` (linePoint2._1) + ,"y2" `parseIn` (linePoint2._2) + ] + +instance XMLUpdatable Ellipse where + xmlTagName _ = "ellipse" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["cx" `parseIn` (ellipseCenter._1) + ,"cy" `parseIn` (ellipseCenter._2) + ,"rx" `parseIn` ellipseXRadius + ,"ry" `parseIn` ellipseYRadius + ] + +instance XMLUpdatable Circle where + xmlTagName _ = "circle" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["cx" `parseIn` (circleCenter._1) + ,"cy" `parseIn` (circleCenter._2) + ,"r" `parseIn` circleRadius + ] + +instance XMLUpdatable Mask where + xmlTagName _ = "mask" + serializeTreeNode node = + updateWithAccessor _maskContent node $ + genericSerializeWithDrawAttr node + + attributes = + ["x" `parseIn` (maskPosition._1) + ,"y" `parseIn` (maskPosition._2) + ,"width" `parseIn` maskWidth + ,"height" `parseIn` maskHeight + ,"maskContentUnits" `parseIn` maskContentUnits + ,"maskUnits" `parseIn` maskUnits + ] + +instance XMLUpdatable ClipPath where + xmlTagName _ = "clipPath" + serializeTreeNode node = + updateWithAccessor _clipPathContent node $ + genericSerializeWithDrawAttr node + attributes = + ["clipPathUnits" `parseIn` clipPathUnits] + +instance XMLUpdatable Polygon where + xmlTagName _ = "polygon" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["points" `parseIn` polygonPoints] + +instance XMLUpdatable PolyLine where + xmlTagName _ = "polyline" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["points" `parseIn` polyLinePoints] + +instance XMLUpdatable Path where + xmlTagName _ = "path" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["d" `parseIn` pathDefinition] + +instance XMLUpdatable LinearGradient where + xmlTagName _ = "linearGradient" + serializeTreeNode node = + updateWithAccessor _linearGradientStops node $ genericSerializeNode node + + attributes = + ["gradientTransform" `parseIn` linearGradientTransform + ,"gradientUnits" `parseIn` linearGradientUnits + ,"spreadMethod" `parseIn` linearGradientSpread + ,"x1" `parseIn` (linearGradientStart._1) + ,"y1" `parseIn` (linearGradientStart._2) + ,"x2" `parseIn` (linearGradientStop._1) + ,"y2" `parseIn` (linearGradientStop._2) + ] + +instance XMLUpdatable Tree where + xmlTagName _ = "TREE" + attributes = [] + serializeTreeNode e = case e of + None -> X.blank_element + UseTree u _ -> serializeTreeNode u + GroupTree g -> serializeTreeNode g + SymbolTree s -> serializeTreeNode s + PathTree p -> serializeTreeNode p + CircleTree c -> serializeTreeNode c + PolyLineTree p -> serializeTreeNode p + PolygonTree p -> serializeTreeNode p + EllipseTree el -> serializeTreeNode el + LineTree l -> serializeTreeNode l + RectangleTree r -> serializeTreeNode r + TextTree Nothing t -> serializeTreeNode t + ImageTree i -> serializeTreeNode i + TextTree (Just p) t -> + setChildren textNode [X.Elem . setChildren pathNode $ X.elContent textNode] + where + textNode = serializeTreeNode t + pathNode = serializeTreeNode p + + +isNotNone :: Tree -> Bool +isNotNone None = False +isNotNone _ = True + +instance XMLUpdatable (Group Tree) where + xmlTagName _ = "g" + serializeTreeNode node = + updateWithAccessor (filter isNotNone . _groupChildren) node $ + genericSerializeWithDrawAttr node + attributes = [] + +instance XMLUpdatable (Symbol Tree) where + xmlTagName _ = "symbol" + serializeTreeNode node = + updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $ + genericSerializeWithDrawAttr node + attributes = + ["viewBox" `parseIn` (groupOfSymbol . groupViewBox)] + + +instance XMLUpdatable RadialGradient where + xmlTagName _ = "radialGradient" + serializeTreeNode node = + updateWithAccessor _radialGradientStops node $ genericSerializeNode node + attributes = + ["gradientTransform" `parseIn` radialGradientTransform + ,"gradientUnits" `parseIn` radialGradientUnits + ,"spreadMethod" `parseIn` radialGradientSpread + ,"cx" `parseIn` (radialGradientCenter._1) + ,"cy" `parseIn` (radialGradientCenter._2) + ,"r" `parseIn` radialGradientRadius + ,"fx" `parseIn` radialGradientFocusX + ,"fy" `parseIn` radialGradientFocusY + ] + +instance XMLUpdatable Use where + xmlTagName _ = "use" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["x" `parseIn` (useBase._1) + ,"y" `parseIn` (useBase._2) + ,"width" `parseIn` useWidth + ,"height" `parseIn` useHeight + ,parserSetter "href" useName (Just . dropSharp) (Just . ('#':)) + ] + +dropSharp :: String -> String +dropSharp ('#':rest) = rest +dropSharp a = a + +instance XMLUpdatable TextInfo where + xmlTagName _ = "tspan" + serializeTreeNode = genericSerializeNode + attributes = + [parserSetter "x" textInfoX (parse dashArray) dashNotEmpty + ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty + ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty + ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty + ,parserSetter "rotate" textInfoRotate + (parse numberList) + rotateNotEmpty + ,"textLength" `parseIn` textInfoLength + ] + where + dashNotEmpty [] = Nothing + dashNotEmpty lst = Just $ serializeDashArray lst + + rotateNotEmpty [] = Nothing + rotateNotEmpty lst = + Just . unwords $ printf "%g" <$> lst + + +instance XMLUpdatable TextPath where + xmlTagName _ = "textPath" + serializeTreeNode = genericSerializeNode + attributes = + ["startOffset" `parseIn` textPathStartOffset + ,"method" `parseIn` textPathMethod + ,"spacing" `parseIn` textPathSpacing + ,parserSetter "href" textPathName (Just . dropSharp) (Just . ('#':)) + ] + +instance XMLUpdatable Text where + xmlTagName _ = "text" + serializeTreeNode = serializeText + attributes = ["lengthAdjust" `parseIn` textAdjust] + + +instance XMLUpdatable Pattern where + xmlTagName _ = "pattern" + serializeTreeNode node = + updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node + attributes = + ["viewBox" `parseIn` patternViewBox + ,"patternUnits" `parseIn` patternUnit + ,"width" `parseIn` patternWidth + ,"height" `parseIn` patternHeight + ,"x" `parseIn` (patternPos._1) + ,"y" `parseIn` (patternPos._2) + ] + +instance XMLUpdatable Marker where + xmlTagName _ = "marker" + serializeTreeNode node = + updateWithAccessor _markerElements node $ genericSerializeWithDrawAttr node + attributes = + ["refX" `parseIn` (markerRefPoint._1) + ,"refY" `parseIn` (markerRefPoint._2) + ,"markerWidth" `parseIn` markerWidth + ,"markerHeight" `parseIn` markerHeight + ,"patternUnits" `parseIn` markerUnits + ,"orient" `parseIn` markerOrient + ,"viewBox" `parseIn` markerViewBox + ] + +serializeText :: Text -> X.Element +serializeText topText = topNode { X.elName = X.unqual "text" } where + topNode = serializeSpan $ _textRoot topText + + serializeSpan tspan = setChildren (mergeAttributes info drawInfo) subContent + where + info = genericSerializeNode $ _spanInfo tspan + drawInfo = genericSerializeNode $ _spanDrawAttributes tspan + subContent = serializeContent <$> _spanContent tspan + + serializeContent (SpanText t) = X.Text $ X.blank_cdata { X.cdData = T.unpack t } + serializeContent (SpanTextRef _t) = X.Text $ X.blank_cdata { X.cdData = "" } + serializeContent (SpanSub sub) = X.Elem $ serializeSpan sub + +unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath) +unparseText = extractResult . go True + where + extractResult (a, b, _) = (a, b) + + go startStrip [] = ([], Nothing, startStrip) + go startStrip (X.CRef _:rest) = go startStrip rest + go startStrip (X.Elem e@(nodeName -> "tspan"):rest) = + (SpanSub spans : trest, mpath, retStrip) + where + (trest, mpath, retStrip) = go restStrip rest + (sub, _, restStrip) = go startStrip $ X.elContent e + spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub + + go startStrip (X.Elem e@(nodeName -> "tref"):rest) = + case attributeFinder "href" e of + Nothing -> go startStrip rest + Just v -> (SpanTextRef v : trest, mpath, stripRet) + where (trest, mpath, stripRet) = go startStrip rest + + go startStrip (X.Elem e@(nodeName -> "textPath"):rest) = + case attributeFinder "href" e of + Nothing -> go startStrip rest + Just v -> (tsub ++ trest, pure p, retStrp) + where + p = (xmlUnparse e) { _textPathName = dropSharp v } + (trest, _, retStrp) = go restStrip rest + (tsub, _, restStrip) = go startStrip $ X.elContent e + + go startStrip (X.Elem _:rest) = go startStrip rest + go startStrip (X.Text t:rest) + | T.length cleanText == 0 = go startStrip rest + | otherwise = + (SpanText cleanText : trest, mpath, stripRet) + where + (trest, mpath, stripRet) = go subShouldStrip rest + + subShouldStrip = T.pack " " `T.isSuffixOf` cleanText + + space = T.singleton ' ' + singulariseSpaces tt + | space `T.isPrefixOf` tt = space + | otherwise = tt + + stripStart | startStrip = T.stripStart + | otherwise = id + + cleanText = stripStart + . T.concat + . fmap singulariseSpaces + . T.groupBy (\a b -> (a /= ' ' && b /= ' ') || a == b) + . T.filter (\c -> c /= '\n' && c /= '\r') + . T.map (\c -> if c == '\t' then ' ' else c) + . T.pack + $ X.cdData t + +gradientOffsetSetter :: SvgAttributeLens GradientStop +gradientOffsetSetter = SvgAttributeLens "offset" setter serialize + where + serialize a = Just $ printf "%d%%" percentage + where percentage = floor . (100 *) $ a ^. gradientOffset :: Int + + setter el str = el & gradientOffset .~ val + where + val = case parseMayStartDot complexNumber str of + Nothing -> 0 + Just (Num n) -> n + Just (Px n) -> n + Just (Percent n) -> n + Just (Em n) -> n + Just (Pc n) -> n + Just (Mm n) -> n + Just (Cm n) -> n + Just (Point n) -> n + Just (Inches n) -> n + +instance XMLUpdatable GradientStop where + xmlTagName _ = "stop" + serializeTreeNode = genericSerializeNode + attributes = + [gradientOffsetSetter + ,"stop-color" `parseIn` gradientColor + ] + + +data Symbols = Symbols + { symbols :: !(M.Map String Element) + , cssStyle :: [CssRule] + } + +emptyState :: Symbols +emptyState = Symbols mempty mempty + +parseGradientStops :: X.Element -> [GradientStop] +parseGradientStops = concatMap unStop . elChildren + where + unStop e@(nodeName -> "stop") = [xmlUnparse e] + unStop _ = [] + +withId :: X.Element -> (X.Element -> Element) + -> State Symbols Tree +withId el f = case attributeFinder "id" el of + Nothing -> return None + Just elemId -> do + modify $ \s -> + s { symbols = M.insert elemId (f el) $ symbols s } + return None + +unparseDefs :: X.Element -> State Symbols Tree +unparseDefs e@(nodeName -> "pattern") = do + subElements <- mapM unparse $ elChildren e + withId e . const . ElementPattern $ pat { _patternElements = subElements} + where + pat = xmlUnparse e +unparseDefs e@(nodeName -> "marker") = do + subElements <- mapM unparse $ elChildren e + withId e . const . ElementMarker $ mark {_markerElements = subElements } + where + mark = xmlUnparseWithDrawAttr e +unparseDefs e@(nodeName -> "mask") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + parsedMask = xmlUnparseWithDrawAttr e + withId e . const . ElementMask $ parsedMask { _maskContent = realChildren } + +unparseDefs e@(nodeName -> "clipPath") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + parsedClip = xmlUnparseWithDrawAttr e + withId e . const . ElementClipPath $ parsedClip { _clipPathContent = realChildren } + +unparseDefs e@(nodeName -> "linearGradient") = + withId e $ ElementLinearGradient . unparser + where + unparser ee = + xmlUnparse ee & linearGradientStops .~ parseGradientStops ee +unparseDefs e@(nodeName -> "radialGradient") = + withId e $ ElementRadialGradient . unparser + where + unparser ee = + xmlUnparse ee & radialGradientStops .~ parseGradientStops ee +unparseDefs e = do + el <- unparse e + withId e (const $ ElementGeometry el) + +unparse :: X.Element -> State Symbols Tree +unparse e@(nodeName -> "style") = do + case parseOnly (many1 ruleSet) . T.pack $ strContent e of + Left _ -> return () + Right rules -> + modify $ \s -> s { cssStyle = cssStyle s ++ rules } + return None +unparse e@(nodeName -> "defs") = do + mapM_ unparseDefs $ elChildren e + return None +unparse e@(nodeName -> "symbol") = do + symbolChildren <- mapM unparse $ elChildren e + let realChildren = filter isNotNone symbolChildren + pure . SymbolTree . Symbol $ groupNode & groupChildren .~ realChildren + where + groupNode :: Group Tree + groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e + +unparse e@(nodeName -> "g") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + + groupNode :: Group Tree + groupNode = xmlUnparseWithDrawAttr e + + pure $ GroupTree $ groupNode & groupChildren .~ realChildren + +unparse e@(nodeName -> "text") = do + pathWithGeometry <- pathGeomtryOf tPath + pure . TextTree pathWithGeometry $ xmlUnparse e & textRoot .~ root + where + (textContent, tPath) = unparseText $ X.elContent e + + pathGeomtryOf Nothing = pure Nothing + pathGeomtryOf (Just pathInfo) = do + pathElem <- gets $ M.lookup (_textPathName pathInfo) . symbols + case pathElem of + Nothing -> pure Nothing + Just (ElementLinearGradient _) -> pure Nothing + Just (ElementRadialGradient _) -> pure Nothing + Just (ElementPattern _) -> pure Nothing + Just (ElementMask _) -> pure Nothing + Just (ElementClipPath _) -> pure Nothing + Just (ElementMarker _) -> pure Nothing + Just (ElementGeometry (PathTree p)) -> + pure . Just $ pathInfo { _textPathData = _pathDefinition p } + Just (ElementGeometry _) -> pure Nothing + + root = TextSpan + { _spanInfo = xmlUnparse e + , _spanDrawAttributes = xmlUnparse e + , _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 + "use" -> UseTree parsed Nothing + _ -> None + where + parsed :: (XMLUpdatable a, WithDrawAttributes a) => a + parsed = xmlUnparseWithDrawAttr e + +unparseDocument :: FilePath -> X.Element -> Maybe Document +unparseDocument rootLocation e@(nodeName -> "svg") = Just Document + { _viewBox = + attributeFinder "viewBox" e >>= parse viewBoxParser + , _elements = parsedElements + , _width = lengthFind "width" + , _height = lengthFind "height" + , _definitions = symbols named + , _description = "" + , _styleRules = cssStyle named + , _documentLocation = rootLocation + } + where + (parsedElements, named) = + runState (mapM unparse $ elChildren e) emptyState + lengthFind n = + attributeFinder n e >>= parse complexNumber +unparseDocument _ _ = Nothing + +-- | Transform a SVG document to a XML node. +xmlOfDocument :: Document -> X.Element +xmlOfDocument doc = + X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ defsTag ++ children) + where + attr name = X.Attr (X.unqual name) + children = [serializeTreeNode el | el <- _elements doc, isNotNone el ] + + defsTag | null defs = [] + | otherwise = [X.node (X.unqual "defs") defs] + + defs = [elementRender k e | (k, e) <- M.assocs $ _definitions doc + , isElementNotNone e] + + isElementNotNone (ElementGeometry el) = isNotNone el + isElementNotNone _ = True + + elementRender k e = case e of + ElementGeometry t -> serializeTreeNode t + ElementMarker m -> serializeTreeNode m + ElementMask m -> serializeTreeNode m + ElementClipPath c -> serializeTreeNode c + ElementPattern p -> + X.add_attr (attr "id" k) $ serializeTreeNode p + ElementLinearGradient lg -> + X.add_attr (attr "id" k) $ serializeTreeNode lg + ElementRadialGradient rg -> + X.add_attr (attr "id" k) $ serializeTreeNode rg + + docViewBox = case _viewBox doc of + Nothing -> [] + Just b -> [attr "viewBox" $ serializeViewBox b] + + descTag = case _description doc of + "" -> [] + txt -> [X.node (X.unqual "desc") txt] + + styleTag = case _styleRules doc of + [] -> [] + rules -> [X.node (X.unqual "style") + ([attr "type" "text/css"], txt)] + where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules + + attrs = + docViewBox ++ + [attr "xmlns" "http://www.w3.org/2000/svg" + ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink" + ,attr "version" "1.1"] ++ + catMaybes [attr "width" . serializeNumber <$> _width doc + ,attr "height" . serializeNumber <$> _height doc + ] + diff --git a/svg-tree.cabal b/svg-tree.cabal --- a/svg-tree.cabal +++ b/svg-tree.cabal @@ -1,62 +1,62 @@ -name: svg-tree -version: 0.1.0.2 -synopsis: SVG file loader and serializer -description: - svg-tree provides types representing a SVG document, - and allows to load and save it. - . - The types definition are aimed at rendering, - so they are rather comple. For simpler SVG document building, - look after `lucid-svg`. - . - To render an svg document you can use the `rasterific-svg` package - - -license: BSD3 -author: Vincent Berthoux -maintainer: Vincent Berthoux --- copyright: -category: Graphics, Svg -build-type: Simple -cabal-version: >=1.10 - -extra-source-files: changelog - -Source-Repository head - Type: git - Location: git://github.com/Twinside/svg-tree.git - -Source-Repository this - Type: git - Location: git://github.com/Twinside/svg-tree.git - Tag: v0.1.0.2 - -library - hs-source-dirs: src - Ghc-options: -O3 -Wall - ghc-prof-options: -rtsopts -Wall -prof -auto-all - default-language: Haskell2010 - exposed-modules: Graphics.Svg - , Graphics.Svg.CssTypes - , Graphics.Svg.Types - - other-modules: Graphics.Svg.NamedColors - , Graphics.Svg.XmlParser - , Graphics.Svg.PathParser - , Graphics.Svg.CssParser - , Graphics.Svg.ColorParser - - build-depends: base >= 4.6 && < 4.9 - , JuicyPixels >= 3.2 - , attoparsec >= 0.12 - , scientific >= 0.3 - , containers >= 0.5 - , xml >= 1.3 - , bytestring >= 0.10 - , linear >= 1.16 - , vector >= 0.10 - , text >= 1.2 - , transformers >= 0.3 && < 0.5 - , mtl >= 2.1 && < 2.3 - , lens >= 4.6 && < 4.9 - +name: svg-tree +version: 0.1.1 +synopsis: SVG file loader and serializer +description: + svg-tree provides types representing a SVG document, + and allows to load and save it. + . + The types definition are aimed at rendering, + so they are rather comple. For simpler SVG document building, + look after `lucid-svg`. + . + To render an svg document you can use the `rasterific-svg` package + + +license: BSD3 +author: Vincent Berthoux +maintainer: Vincent Berthoux +-- copyright: +category: Graphics, Svg +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: changelog + +Source-Repository head + Type: git + Location: git://github.com/Twinside/svg-tree.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/svg-tree.git + Tag: v0.1.1 + +library + hs-source-dirs: src + Ghc-options: -O3 -Wall + ghc-prof-options: -rtsopts -Wall -prof -auto-all + default-language: Haskell2010 + exposed-modules: Graphics.Svg + , Graphics.Svg.CssTypes + , Graphics.Svg.Types + + other-modules: Graphics.Svg.NamedColors + , Graphics.Svg.XmlParser + , Graphics.Svg.PathParser + , Graphics.Svg.CssParser + , Graphics.Svg.ColorParser + + build-depends: base >= 4.6 && < 4.9 + , JuicyPixels >= 3.2 + , attoparsec >= 0.12 + , scientific >= 0.3 + , containers >= 0.5 + , xml >= 1.3 + , bytestring >= 0.10 + , linear >= 1.16 + , vector >= 0.10 + , text >= 1.2 + , transformers >= 0.3 && < 0.5 + , mtl >= 2.1 && < 2.3 + , lens >= 4.6 && < 4.10 +