diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,57 +1,60 @@ --*-change-log-*- - -v0.5.1.1: May 2016 - * Fix: GHC 8.0 compatibility - -v0.5.1: March 2016 - * Fix: serialization of multi criteria css selector. - -v0.5: March 2016: - * Adding: preserveAspectRatio attribute - * Fix: Application of CSS rules with indirect parent/child relation. - -v0.4.2: March 2016 - * Enhancement: avoiding serializatinon of empty class attribute - * Fix: incorrect deserialization of complex CSS - * Fix: Really fixing duplicate ID with serialization - -v0.4.1: February 2016 - * Fix: fixing duplicate ID with serialization - -v0.4: February 2016 - * Breaking change: viewbox types are no longer Int - but double, sneakingly passed in v0.3.2.2. This - version acknoweledge this change - -V0.3.2.2 February 2016 (Deprecated) - * Fix: Bad serialization of some None constructors. - -v0.3.2.1 October 2015 - * Fix: Don't add '#' for serialization - -v0.3.2 August 2015 - * Fix: allow compilation with GHC 7.4 - -v0.3.1 May 2015 - * Fix: Bumping lens dependency and removing upper bound. - -v0.3 April 2015 - * Breaking change: Switching all the numeric types associated to geometry - to Double precision (thx to Kasbah) - -v0.2 April 2015 - * Fix: Differentiating opacity & fill-opacity, as they are - semantically deferent (BREAKING CHANGE!) - -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 - +-*-change-log-*- + +v0.5.1.2: September 2016 + * Fix path parsing with white space prefix + +v0.5.1.1: May 2016 + * Fix: GHC 8.0 compatibility + +v0.5.1: March 2016 + * Fix: serialization of multi criteria css selector. + +v0.5: March 2016: + * Adding: preserveAspectRatio attribute + * Fix: Application of CSS rules with indirect parent/child relation. + +v0.4.2: March 2016 + * Enhancement: avoiding serializatinon of empty class attribute + * Fix: incorrect deserialization of complex CSS + * Fix: Really fixing duplicate ID with serialization + +v0.4.1: February 2016 + * Fix: fixing duplicate ID with serialization + +v0.4: February 2016 + * Breaking change: viewbox types are no longer Int + but double, sneakingly passed in v0.3.2.2. This + version acknoweledge this change + +V0.3.2.2 February 2016 (Deprecated) + * Fix: Bad serialization of some None constructors. + +v0.3.2.1 October 2015 + * Fix: Don't add '#' for serialization + +v0.3.2 August 2015 + * Fix: allow compilation with GHC 7.4 + +v0.3.1 May 2015 + * Fix: Bumping lens dependency and removing upper bound. + +v0.3 April 2015 + * Breaking change: Switching all the numeric types associated to geometry + to Double precision (thx to Kasbah) + +v0.2 April 2015 + * Fix: Differentiating opacity & fill-opacity, as they are + semantically deferent (BREAKING CHANGE!) + +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,111 +1,111 @@ -{-# 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 } - +{-# 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 Double - doubleNumber = toRealFloat <$> scientific - - plusMinus = negate <$ string "-" <*> doubleNumber - <|> string "+" *> doubleNumber - <|> doubleNumber - -colorSerializer :: PixelRGBA8 -> String -colorSerializer (PixelRGBA8 r g b _) = printf "#%02X%02X%02X" r g b - -colorParser :: Parser PixelRGBA8 -colorParser = rgbColor - <|> (string "#" *> (color <|> colorReduced)) - <|> namedColor - where - charRange c1 c2 = - (\c -> fromIntegral $ fromEnum c - fromEnum c1) <$> satisfy (\v -> c1 <= v && v <= c2) - black = PixelRGBA8 0 0 0 255 - - hexChar :: Parser Word8 - hexChar = charRange '0' '9' - <|> ((+ 10) <$> charRange 'a' 'f') - <|> ((+ 10) <$> charRange 'A' 'F') - - namedColor = do - str <- takeWhile1 (inClass "a-z") - return $ M.findWithDefault black str svgNamedColors - - percentToWord v = floor $ v * (255 / 100) - - numPercent = ((percentToWord <$> num) <* string "%") - <|> (floor <$> num) - - hexByte = (\h1 h2 -> h1 `unsafeShiftL` 4 .|. h2) - <$> hexChar <*> hexChar - - color = (\r g b -> PixelRGBA8 r g b 255) - <$> hexByte <*> hexByte <*> hexByte - rgbColor = (\r g b -> PixelRGBA8 r g b 255) - <$> (string "rgb(" *> numPercent) - <*> (commaWsp *> numPercent) - <*> (commaWsp *> numPercent <* skipSpace <* string ")") - - colorReduced = - (\r g b -> PixelRGBA8 (r * 17) (g * 17) (b * 17) 255) - <$> hexChar <*> hexChar <*> hexChar - - -textureSerializer :: Texture -> String -textureSerializer (ColorRef px) = colorSerializer px -textureSerializer (TextureRef str) = printf "url(#%s)" str -textureSerializer FillNone = "none" - -urlRef :: Parser String -urlRef = string "url(" *> skipSpace *> - char '#' *> many1 (letter <|> digit) - <* skipSpace <* char ')' <* skipSpace - - -textureParser :: Parser Texture -textureParser = - none <|> (TextureRef <$> urlRef) - <|> (ColorRef <$> colorParser) - where - none = FillNone <$ string "none" - +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Svg.ColorParser( colorParser + , colorSerializer + , textureParser + , textureSerializer + , urlRef + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) ) +#endif + +import Data.Bits( (.|.), unsafeShiftL ) +import Control.Applicative( (<|>) ) +import Data.Attoparsec.Text + ( Parser + , string + , skipSpace + , satisfy + , inClass + , takeWhile1 + , option + , char + , digit + , letter + , many1 + , scientific + ) + +import Text.Printf( printf ) +import Data.Scientific( toRealFloat ) +import Codec.Picture( PixelRGBA8( .. ) ) +import Data.Word( Word8 ) +import Graphics.Svg.NamedColors +import Graphics.Svg.Types +import qualified Data.Map as M + +commaWsp :: Parser () +commaWsp = skipSpace *> option () (string "," *> return ()) + <* skipSpace + + +num :: Parser Double +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber :: Parser Double + doubleNumber = toRealFloat <$> scientific + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + +colorSerializer :: PixelRGBA8 -> String +colorSerializer (PixelRGBA8 r g b _) = printf "#%02X%02X%02X" r g b + +colorParser :: Parser PixelRGBA8 +colorParser = rgbColor + <|> (string "#" *> (color <|> colorReduced)) + <|> namedColor + where + charRange c1 c2 = + (\c -> fromIntegral $ fromEnum c - fromEnum c1) <$> satisfy (\v -> c1 <= v && v <= c2) + black = PixelRGBA8 0 0 0 255 + + hexChar :: Parser Word8 + hexChar = charRange '0' '9' + <|> ((+ 10) <$> charRange 'a' 'f') + <|> ((+ 10) <$> charRange 'A' 'F') + + namedColor = do + str <- takeWhile1 (inClass "a-z") + return $ M.findWithDefault black str svgNamedColors + + percentToWord v = floor $ v * (255 / 100) + + numPercent = ((percentToWord <$> num) <* string "%") + <|> (floor <$> num) + + hexByte = (\h1 h2 -> h1 `unsafeShiftL` 4 .|. h2) + <$> hexChar <*> hexChar + + color = (\r g b -> PixelRGBA8 r g b 255) + <$> hexByte <*> hexByte <*> hexByte + rgbColor = (\r g b -> PixelRGBA8 r g b 255) + <$> (string "rgb(" *> numPercent) + <*> (commaWsp *> numPercent) + <*> (commaWsp *> numPercent <* skipSpace <* string ")") + + colorReduced = + (\r g b -> PixelRGBA8 (r * 17) (g * 17) (b * 17) 255) + <$> hexChar <*> hexChar <*> hexChar + + +textureSerializer :: Texture -> String +textureSerializer (ColorRef px) = colorSerializer px +textureSerializer (TextureRef str) = printf "url(#%s)" str +textureSerializer FillNone = "none" + +urlRef :: Parser String +urlRef = string "url(" *> skipSpace *> + char '#' *> many1 (letter <|> digit) + <* 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 Double -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 [Double] -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 Double +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 [Double] +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/CssTypes.hs b/src/Graphics/Svg/CssTypes.hs --- a/src/Graphics/Svg/CssTypes.hs +++ b/src/Graphics/Svg/CssTypes.hs @@ -1,271 +1,271 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} --- | Define the types used to describes CSS elements -module Graphics.Svg.CssTypes - ( CssSelector( .. ) - , CssSelectorRule - , CssRule( .. ) - , CssDescriptor( .. ) - , CssDeclaration( .. ) - , CssElement( .. ) - - , CssMatcheable( .. ) - , CssContext - , Dpi - , Number( .. ) - , serializeNumber - , findMatchingDeclarations - , toUserUnit - , mapNumber - , tserialize - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mconcat ) -#endif - -import Data.Monoid( (<>) ) -import Data.List( intersperse ) -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as TB -import Text.Printf - -import Codec.Picture( PixelRGBA8( .. ) ) - --- | Alias describing a "dot per inch" information --- used for size calculation (see toUserUnit). -type Dpi = Int - --- | Helper typeclass for serialization to Text. -class TextBuildable a where - -- | Serialize an element to a text builder. - tserialize :: a -> TB.Builder - --- | Describe an element of a CSS selector. Multiple --- elements can be combined in a CssSelector type. -data CssDescriptor - = OfClass T.Text -- ^ .IDENT - | OfName T.Text -- ^ IDENT - | OfId T.Text -- ^ #IDENT - | OfPseudoClass T.Text -- ^ `:IDENT` (ignore function syntax) - | AnyElem -- ^ '*' - | WithAttrib T.Text T.Text -- ^ `` - deriving (Eq, Show) - -instance TextBuildable CssDescriptor where - tserialize d = case d of - OfClass c -> si '.' <> ft c - OfName n -> ft n - OfId i -> si '#' <> ft i - OfPseudoClass c -> si '#' <> ft c - AnyElem -> si '*' - WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']'] - where - ft = TB.fromText - si = TB.singleton - --- | Define complex selector. -data CssSelector - = Nearby -- ^ Correspond to the `+` CSS selector. - | DirectChildren -- ^ Correspond to the `>` CSS selectro. - | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements - -- of the list must be matched. - deriving (Eq, Show) - -instance TextBuildable CssSelector where - tserialize s = case s of - Nearby -> si '+' - DirectChildren -> si '>' - AllOf lst -> mconcat $ map tserialize lst - where - si = TB.singleton - --- | A CssSelectorRule is a list of all the elements --- that must be meet in a depth first search fashion. -type CssSelectorRule = [CssSelector] - --- | Represent a CSS selector and the different declarations --- to apply to the matched elemens. -data CssRule = CssRule - { -- | At the first level represent a list of elements - -- to be matched. If any match is made, you can apply - -- the declarations. At the second level - cssRuleSelector :: ![CssSelectorRule] - -- | Declarations to apply to the matched element. - , cssDeclarations :: ![CssDeclaration] - } - deriving (Eq, Show) - -instance TextBuildable CssRule where - tserialize (CssRule selectors decl) = - mconcat tselectors - <> ft " {\n" - <> mconcat (fmap tserializeDecl decl) - <> ft "}\n" - where - ft = TB.fromText - tserializeDecl d = ft " " <> tserialize d <> ft ";\n" - tselector = - mconcat . intersperse (ft " ") . fmap tserialize - tselectors = - intersperse (ft ",\n") $ fmap tselector selectors - --- | Interface for elements to be matched against --- some CssRule. -class CssMatcheable a where - -- | For an element, tell its optional ID attribute. - cssIdOf :: a -> Maybe T.Text - -- | For an element, return all of it's class attributes. - cssClassOf :: a -> [T.Text] - -- | Return the name of the tagname of the element - cssNameOf :: a -> T.Text - -- | Return a value of a given attribute if present - cssAttribOf :: a -> T.Text -> Maybe T.Text - --- | Represent a zipper in depth at the first list --- level, and the previous nodes at in the second --- list level. -type CssContext a = [[a]] - -isDescribedBy :: CssMatcheable a - => a -> [CssDescriptor] -> Bool -isDescribedBy e = all tryMatch - where - tryMatch (OfClass t) = t `elem` cssClassOf e - tryMatch (OfId i) = cssIdOf e == Just i - tryMatch (OfName n) = cssNameOf e == n - tryMatch (OfPseudoClass _) = False - tryMatch (WithAttrib a v) = cssAttribOf e a == Just v - tryMatch AnyElem = True - -isMatching :: CssMatcheable a - => CssContext a -> [CssSelector] -> Bool -isMatching = go where - go _ [] = True - go [] _ = False - go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest - go ((e:_):upper) (DirectChildren:AllOf descr:rest) - | isDescribedBy e descr = go upper rest - go _ (DirectChildren:_) = False - go ((e:_):upper) selectors@(AllOf descr : rest) - | isDescribedBy e descr = go upper rest - | otherwise = go upper selectors - go (_:upper) selector = go upper selector - --- | Given CSS rules, find all the declaration to apply to the --- element in a given context. -findMatchingDeclarations :: CssMatcheable a - => [CssRule] -> CssContext a -> [CssDeclaration] -findMatchingDeclarations rules context = - concat [cssDeclarations rule - | rule <- rules - , selector <- cssRuleSelector rule - , isMatching context $ reverse selector ] - --- | Represent the content to apply to some --- CSS matched rules. -data CssDeclaration = CssDeclaration - { -- | Property name to change (like font-family or color). - _cssDeclarationProperty :: T.Text - -- | List of values - , _cssDecarationlValues :: [[CssElement]] - } - deriving (Eq, Show) - -instance TextBuildable CssDeclaration where - tserialize (CssDeclaration n elems) = - mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems - where - finalElems = map tserialize (concat elems) - ft = TB.fromText - si = TB.singleton - - --- | Encode complex number possibly dependant to the current --- render size. -data Number - = Num Double -- ^ Simple coordinate in current user coordinate. - | Px Double -- ^ With suffix "px" - | Em Double -- ^ Number relative to the current font size. - | Percent Double -- ^ Number relative to the current viewport size. - | Pc Double - | Mm Double -- ^ Number in millimeters, relative to DPI. - | Cm Double -- ^ Number in centimeters, relative to DPI. - | Point Double -- ^ Number in points, relative to DPI. - | Inches Double -- ^ Number in inches, relative to DPI. - deriving (Eq, Show) - --- | Helper function to modify inner value of a number -mapNumber :: (Double -> Double) -> Number -> Number -mapNumber f nu = case nu of - Num n -> Num $ f n - Px n -> Px $ f n - Em n -> Em $ f n - Percent n -> Percent $ f n - Pc n -> Pc $ f n - Mm n -> Mm $ f n - Cm n -> Cm $ f n - Point n -> Point $ f n - Inches n -> Inches $ f n - --- | Encode the number to string which can be used in a --- CSS or a svg attributes. -serializeNumber :: Number -> String -serializeNumber n = case n of - Num c -> printf "%g" c - Px c -> printf "%gpx" c - Em cc -> printf "%gem" cc - Percent p -> printf "%d%%" (floor $ 100 * p :: Int) - Pc p -> printf "%gpc" p - Mm m -> printf "%gmm" m - Cm c -> printf "%gcm" c - Point p -> printf "%gpt" p - Inches i -> printf "%gin" i - -instance TextBuildable Number where - tserialize = TB.fromText . T.pack . serializeNumber - --- | Value of a CSS property. -data CssElement - = CssIdent !T.Text - | CssString !T.Text - | CssReference !T.Text - | CssNumber !Number - | CssColor !PixelRGBA8 - | CssFunction !T.Text ![CssElement] - | CssOpComa - | CssOpSlash - deriving (Eq, Show) - -instance TextBuildable CssElement where - tserialize e = case e of - CssIdent n -> ft n - CssString s -> si '"' <> ft s <> si '"' - CssReference r -> si '#' <> ft r - CssNumber n -> tserialize n - CssColor (PixelRGBA8 r g b _) -> - ft . T.pack $ printf "#%02X%02X%02X" r g b - CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')'] - where args = intersperse (ft ", ") (map tserialize els) - CssOpComa -> si ',' - CssOpSlash -> si '/' - where - ft = TB.fromText - si = TB.singleton - --- | This function replace all device dependant units to user --- units given it's DPI configuration. --- Preserve percentage and "em" notation. -toUserUnit :: Dpi -> Number -> Number -toUserUnit dpi = go where - go nu = case nu of - Num _ -> nu - Px p -> go $ Num p - Em _ -> nu - Percent _ -> nu - Pc n -> go . Inches $ (12 * n) / 72 - Inches n -> Num $ n * fromIntegral dpi - Mm n -> go . Inches $ n / 25.4 - Cm n -> go . Inches $ n / 2.54 - Point n -> go . Inches $ n / 72 - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +-- | Define the types used to describes CSS elements +module Graphics.Svg.CssTypes + ( CssSelector( .. ) + , CssSelectorRule + , CssRule( .. ) + , CssDescriptor( .. ) + , CssDeclaration( .. ) + , CssElement( .. ) + + , CssMatcheable( .. ) + , CssContext + , Dpi + , Number( .. ) + , serializeNumber + , findMatchingDeclarations + , toUserUnit + , mapNumber + , tserialize + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mconcat ) +#endif + +import Data.Monoid( (<>) ) +import Data.List( intersperse ) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as TB +import Text.Printf + +import Codec.Picture( PixelRGBA8( .. ) ) + +-- | Alias describing a "dot per inch" information +-- used for size calculation (see toUserUnit). +type Dpi = Int + +-- | Helper typeclass for serialization to Text. +class TextBuildable a where + -- | Serialize an element to a text builder. + tserialize :: a -> TB.Builder + +-- | Describe an element of a CSS selector. Multiple +-- elements can be combined in a CssSelector type. +data CssDescriptor + = OfClass T.Text -- ^ .IDENT + | OfName T.Text -- ^ IDENT + | OfId T.Text -- ^ #IDENT + | OfPseudoClass T.Text -- ^ `:IDENT` (ignore function syntax) + | AnyElem -- ^ '*' + | WithAttrib T.Text T.Text -- ^ `` + deriving (Eq, Show) + +instance TextBuildable CssDescriptor where + tserialize d = case d of + OfClass c -> si '.' <> ft c + OfName n -> ft n + OfId i -> si '#' <> ft i + OfPseudoClass c -> si '#' <> ft c + AnyElem -> si '*' + WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']'] + where + ft = TB.fromText + si = TB.singleton + +-- | Define complex selector. +data CssSelector + = Nearby -- ^ Correspond to the `+` CSS selector. + | DirectChildren -- ^ Correspond to the `>` CSS selectro. + | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements + -- of the list must be matched. + deriving (Eq, Show) + +instance TextBuildable CssSelector where + tserialize s = case s of + Nearby -> si '+' + DirectChildren -> si '>' + AllOf lst -> mconcat $ map tserialize lst + where + si = TB.singleton + +-- | A CssSelectorRule is a list of all the elements +-- that must be meet in a depth first search fashion. +type CssSelectorRule = [CssSelector] + +-- | Represent a CSS selector and the different declarations +-- to apply to the matched elemens. +data CssRule = CssRule + { -- | At the first level represent a list of elements + -- to be matched. If any match is made, you can apply + -- the declarations. At the second level + cssRuleSelector :: ![CssSelectorRule] + -- | Declarations to apply to the matched element. + , cssDeclarations :: ![CssDeclaration] + } + deriving (Eq, Show) + +instance TextBuildable CssRule where + tserialize (CssRule selectors decl) = + mconcat tselectors + <> ft " {\n" + <> mconcat (fmap tserializeDecl decl) + <> ft "}\n" + where + ft = TB.fromText + tserializeDecl d = ft " " <> tserialize d <> ft ";\n" + tselector = + mconcat . intersperse (ft " ") . fmap tserialize + tselectors = + intersperse (ft ",\n") $ fmap tselector selectors + +-- | Interface for elements to be matched against +-- some CssRule. +class CssMatcheable a where + -- | For an element, tell its optional ID attribute. + cssIdOf :: a -> Maybe T.Text + -- | For an element, return all of it's class attributes. + cssClassOf :: a -> [T.Text] + -- | Return the name of the tagname of the element + cssNameOf :: a -> T.Text + -- | Return a value of a given attribute if present + cssAttribOf :: a -> T.Text -> Maybe T.Text + +-- | Represent a zipper in depth at the first list +-- level, and the previous nodes at in the second +-- list level. +type CssContext a = [[a]] + +isDescribedBy :: CssMatcheable a + => a -> [CssDescriptor] -> Bool +isDescribedBy e = all tryMatch + where + tryMatch (OfClass t) = t `elem` cssClassOf e + tryMatch (OfId i) = cssIdOf e == Just i + tryMatch (OfName n) = cssNameOf e == n + tryMatch (OfPseudoClass _) = False + tryMatch (WithAttrib a v) = cssAttribOf e a == Just v + tryMatch AnyElem = True + +isMatching :: CssMatcheable a + => CssContext a -> [CssSelector] -> Bool +isMatching = go where + go _ [] = True + go [] _ = False + go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest + go ((e:_):upper) (DirectChildren:AllOf descr:rest) + | isDescribedBy e descr = go upper rest + go _ (DirectChildren:_) = False + go ((e:_):upper) selectors@(AllOf descr : rest) + | isDescribedBy e descr = go upper rest + | otherwise = go upper selectors + go (_:upper) selector = go upper selector + +-- | Given CSS rules, find all the declaration to apply to the +-- element in a given context. +findMatchingDeclarations :: CssMatcheable a + => [CssRule] -> CssContext a -> [CssDeclaration] +findMatchingDeclarations rules context = + concat [cssDeclarations rule + | rule <- rules + , selector <- cssRuleSelector rule + , isMatching context $ reverse selector ] + +-- | Represent the content to apply to some +-- CSS matched rules. +data CssDeclaration = CssDeclaration + { -- | Property name to change (like font-family or color). + _cssDeclarationProperty :: T.Text + -- | List of values + , _cssDecarationlValues :: [[CssElement]] + } + deriving (Eq, Show) + +instance TextBuildable CssDeclaration where + tserialize (CssDeclaration n elems) = + mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems + where + finalElems = map tserialize (concat elems) + ft = TB.fromText + si = TB.singleton + + +-- | Encode complex number possibly dependant to the current +-- render size. +data Number + = Num Double -- ^ Simple coordinate in current user coordinate. + | Px Double -- ^ With suffix "px" + | Em Double -- ^ Number relative to the current font size. + | Percent Double -- ^ Number relative to the current viewport size. + | Pc Double + | Mm Double -- ^ Number in millimeters, relative to DPI. + | Cm Double -- ^ Number in centimeters, relative to DPI. + | Point Double -- ^ Number in points, relative to DPI. + | Inches Double -- ^ Number in inches, relative to DPI. + deriving (Eq, Show) + +-- | Helper function to modify inner value of a number +mapNumber :: (Double -> Double) -> Number -> Number +mapNumber f nu = case nu of + Num n -> Num $ f n + Px n -> Px $ f n + Em n -> Em $ f n + Percent n -> Percent $ f n + Pc n -> Pc $ f n + Mm n -> Mm $ f n + Cm n -> Cm $ f n + Point n -> Point $ f n + Inches n -> Inches $ f n + +-- | Encode the number to string which can be used in a +-- CSS or a svg attributes. +serializeNumber :: Number -> String +serializeNumber n = case n of + Num c -> printf "%g" c + Px c -> printf "%gpx" c + Em cc -> printf "%gem" cc + Percent p -> printf "%d%%" (floor $ 100 * p :: Int) + Pc p -> printf "%gpc" p + Mm m -> printf "%gmm" m + Cm c -> printf "%gcm" c + Point p -> printf "%gpt" p + Inches i -> printf "%gin" i + +instance TextBuildable Number where + tserialize = TB.fromText . T.pack . serializeNumber + +-- | Value of a CSS property. +data CssElement + = CssIdent !T.Text + | CssString !T.Text + | CssReference !T.Text + | CssNumber !Number + | CssColor !PixelRGBA8 + | CssFunction !T.Text ![CssElement] + | CssOpComa + | CssOpSlash + deriving (Eq, Show) + +instance TextBuildable CssElement where + tserialize e = case e of + CssIdent n -> ft n + CssString s -> si '"' <> ft s <> si '"' + CssReference r -> si '#' <> ft r + CssNumber n -> tserialize n + CssColor (PixelRGBA8 r g b _) -> + ft . T.pack $ printf "#%02X%02X%02X" r g b + CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')'] + where args = intersperse (ft ", ") (map tserialize els) + CssOpComa -> si ',' + CssOpSlash -> si '/' + where + ft = TB.fromText + si = TB.singleton + +-- | This function replace all device dependant units to user +-- units given it's DPI configuration. +-- Preserve percentage and "em" notation. +toUserUnit :: Dpi -> Number -> Number +toUserUnit dpi = go where + go nu = case nu of + Num _ -> nu + Px p -> go $ Num p + Em _ -> nu + Percent _ -> nu + Pc n -> go . Inches $ (12 * n) / 72 + Inches n -> Num $ n * fromIntegral dpi + Mm n -> go . Inches $ n / 25.4 + Cm n -> go . Inches $ n / 2.54 + Point n -> go . Inches $ n / 72 + 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,231 @@ -{-# 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 Double -num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) - where doubleNumber :: Parser Double - doubleNumber = toRealFloat <$> scientific - - plusMinus = negate <$ string "-" <*> doubleNumber - <|> string "+" *> doubleNumber - <|> doubleNumber - -viewBoxParser :: Parser (Double, Double, Double, Double) -viewBoxParser = (,,,) - <$> iParse <*> iParse <*> iParse <*> iParse - where - iParse = num <* skipSpace - -serializeViewBox :: (Double, Double, Double, Double) -> String -serializeViewBox (a, b, c, d) = printf "%g %g %g %g" 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) - <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs) - <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs) - <|> (EndPath <$ string "Z" <* commaWsp) - <|> (EndPath <$ string "z" <* commaWsp) - 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 - ellipticalArgs = (,,,,,) <$> numComma - <*> numComma - <*> numComma - <*> (fmap (/= 0) numComma) - <*> (fmap (/= 0) 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 - EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args - EllipticalArc OriginRelative args -> "a" ++ serializeArgs args - EndPath -> "Z" - where - serializeArg (a, b, c, d, e, V2 x y) = - printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y - serializeArgs = unwords . fmap serializeArg - - - -transformParser :: Parser Transformation -transformParser = matrixParser - <|> translationParser - <|> scaleParser - <|> rotateParser - <|> skewYParser - <|> skewXParser - -functionParser :: T.Text -> Parser [Double] -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 + , pathParser + , 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 + , many1 + ) +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 Double +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber :: Parser Double + doubleNumber = toRealFloat <$> scientific + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + +viewBoxParser :: Parser (Double, Double, Double, Double) +viewBoxParser = (,,,) + <$> iParse <*> iParse <*> iParse <*> iParse + where + iParse = num <* skipSpace + +serializeViewBox :: (Double, Double, Double, Double) -> String +serializeViewBox (a, b, c, d) = printf "%g %g %g %g" 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 + +pathParser :: Parser [PathCommand] +pathParser = skipSpace *> many1 command + +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) + <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs) + <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs) + <|> (EndPath <$ string "Z" <* commaWsp) + <|> (EndPath <$ string "z" <* commaWsp) + 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 + ellipticalArgs = (,,,,,) <$> numComma + <*> numComma + <*> numComma + <*> (fmap (/= 0) numComma) + <*> (fmap (/= 0) 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 + EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args + EllipticalArc OriginRelative args -> "a" ++ serializeArgs args + EndPath -> "Z" + where + serializeArg (a, b, c, d, e, V2 x y) = + printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y + serializeArgs = unwords . fmap serializeArg + + + +transformParser :: Parser Transformation +transformParser = matrixParser + <|> translationParser + <|> scaleParser + <|> rotateParser + <|> skewYParser + <|> skewXParser + +functionParser :: T.Text -> Parser [Double] +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/Types.hs b/src/Graphics/Svg/Types.hs --- a/src/Graphics/Svg/Types.hs +++ b/src/Graphics/Svg/Types.hs @@ -1,1521 +1,1521 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} --- | This module define all the types used in the definition --- of a svg scene. --- --- Most of the types are lensified. -module Graphics.Svg.Types - ( -- * Basic building types - Coord - , Origin( .. ) - , Point - , RPoint - , PathCommand( .. ) - , Transformation( .. ) - , ElementRef( .. ) - , CoordinateUnits( .. ) - - -- ** Building helpers - , toPoint - , serializeNumber - , serializeTransformation - , serializeTransformations - - -- * Drawing control types - , Cap( .. ) - , LineJoin( .. ) - , Tree( .. ) - , Number( .. ) - , Spread( .. ) - , Texture( .. ) - , Element( .. ) - , FillRule( .. ) - , FontStyle( .. ) - , Dpi - - , WithDefaultSvg( .. ) - - -- * Main type - , Document( .. ) - , HasDocument( .. ) - , documentSize - - -- * Drawing attributes - , DrawAttributes( .. ) - , HasDrawAttributes( .. ) - , WithDrawAttributes( .. ) - - -- * SVG drawing primitives - -- ** Rectangle - , Rectangle( .. ) - , HasRectangle( .. ) - - -- ** Line - , Line( .. ) - , HasLine( .. ) - - -- ** Polygon - , Polygon( .. ) - , HasPolygon( .. ) - - -- ** Polyline - , PolyLine( .. ) - , HasPolyLine( .. ) - - -- ** Path - , Path( .. ) - , HasPath( .. ) - - -- ** Circle - , Circle( .. ) - , HasCircle( .. ) - - -- ** Ellipse - , Ellipse( .. ) - , HasEllipse( .. ) - - -- ** Image - , Image( .. ) - , HasImage( .. ) - - -- ** Use - , Use( .. ) - , HasUse( .. ) - - -- * Grouping primitives - -- ** Group - , Group( .. ) - , HasGroup( .. ) - - -- ** Symbol - , Symbol( .. ) - , groupOfSymbol - - -- * Text related types - -- ** Text - , Text( .. ) - , HasText( .. ) - , TextAnchor( .. ) - , textAt - - -- ** Text path - , TextPath( .. ) - , HasTextPath( .. ) - - , TextPathSpacing( .. ) - , TextPathMethod( .. ) - - -- ** Text span. - , TextSpanContent( .. ) - - , TextSpan( .. ) - , HasTextSpan( .. ) - - , TextInfo( .. ) - , HasTextInfo( .. ) - - , TextAdjust( .. ) - - -- * Marker definition - , Marker( .. ) - , Overflow( .. ) - , MarkerOrientation( .. ) - , MarkerUnit( .. ) - , HasMarker( .. ) - - -- * Gradient definition - , GradientStop( .. ) - , HasGradientStop( .. ) - - -- ** Linear Gradient - , LinearGradient( .. ) - , HasLinearGradient( .. ) - - -- ** Radial Gradient - , RadialGradient( .. ) - , HasRadialGradient( .. ) - - -- * Pattern definition - , Pattern( .. ) - , HasPattern( .. ) - - -- * Mask definition - , Mask( .. ) - , HasMask( .. ) - - -- * Clip path definition - , ClipPath( .. ) - , HasClipPath( .. ) - - -- * Aspect Ratio description - , PreserveAspectRatio( .. ) - , Alignment( .. ) - , MeetSlice( .. ) - , HasPreserveAspectRatio( .. ) - - -- * MISC functions - , isPathArc - , isPathWithArc - , nameOfTree - , zipTree - , mapTree - , foldTree - , toUserUnit - , mapNumber - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid( .. ) ) -import Data.Foldable( Foldable ) -#endif - -import Data.Function( on ) -import Data.List( inits ) -import qualified Data.Map as M -import Data.Monoid( Last( .. ), (<>) ) -import qualified Data.Foldable as F -import qualified Data.Text as T -import Codec.Picture( PixelRGBA8( .. ) ) -import Control.Lens( Lens' - , lens - , makeClassy - , makeLenses - , view - , (^.) - , (&) - , (.~) - ) -import Graphics.Svg.CssTypes -import Linear hiding ( angle ) - -import Text.Printf - --- | Basic coordiante type. -type Coord = Double - --- | Real Point, fully determined and not --- dependant of the rendering context. -type RPoint = V2 Coord - --- | Possibly context dependant point. -type Point = (Number, Number) - --- | Tell if a path command is absolute (in the current --- user coordiante) or relative to the previous poitn. -data Origin - = OriginAbsolute -- ^ Next point in absolute coordinate - | OriginRelative -- ^ Next point relative to the previous - deriving (Eq, Show) - --- | Path command definition. -data PathCommand - -- | 'M' or 'm' command - = MoveTo !Origin ![RPoint] - -- | Line to, 'L' or 'l' Svg path command. - | LineTo !Origin ![RPoint] - - -- | Equivalent to the 'H' or 'h' svg path command. - | HorizontalTo !Origin ![Coord] - -- | Equivalent to the 'V' or 'v' svg path command. - | VerticalTo !Origin ![Coord] - - -- | Cubic bezier, 'C' or 'c' command - | CurveTo !Origin ![(RPoint, RPoint, RPoint)] - -- | Smooth cubic bezier, equivalent to 'S' or 's' command - | SmoothCurveTo !Origin ![(RPoint, RPoint)] - -- | Quadratic bezier, 'Q' or 'q' command - | QuadraticBezier !Origin ![(RPoint, RPoint)] - -- | Quadratic bezier, 'T' or 't' command - | SmoothQuadraticBezierCurveTo !Origin ![RPoint] - -- | Eliptical arc, 'A' or 'a' command. - | EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)] - -- | Close the path, 'Z' or 'z' svg path command. - | EndPath - deriving (Eq, Show) - --- | Little helper function to build a point. -toPoint :: Number -> Number -> Point -toPoint = (,) - --- | Tell if the path command is an EllipticalArc. -isPathArc :: PathCommand -> Bool -isPathArc (EllipticalArc _ _) = True -isPathArc _ = False - --- | Tell if a full path contain an EllipticalArc. -isPathWithArc :: Foldable f => f PathCommand -> Bool -isPathWithArc = F.any isPathArc - --- | This type represent the align information of the --- preserveAspectRatio SVGattribute -data Alignment - = AlignNone -- ^ "none" value - | AlignxMinYMin -- "xMinYMin" value - | AlignxMidYMin -- ^ "xMidYMin" value - | AlignxMaxYMin -- ^ "xMaxYMin" value - | AlignxMinYMid -- ^ "xMinYMid" value - | AlignxMidYMid -- ^ "xMidYMid" value - | AlignxMaxYMid -- ^ "xMaxYMid" value - | AlignxMinYMax -- ^ "xMinYMax" value - | AlignxMidYMax -- ^ "xMidYMax" value - | AlignxMaxYMax -- ^ "xMaxYMax" value - deriving (Eq, Show) - --- | This type represent the "meet or slice" information --- of the preserveAspectRatio SVGattribute -data MeetSlice = Meet | Slice - deriving (Eq, Show) - --- | Describe the content of the preserveAspectRatio attribute. -data PreserveAspectRatio = PreserveAspectRatio - { _aspectRatioDefer :: !Bool - , _aspectRatioAlign :: !Alignment - , _aspectRatioMeetSlice :: !(Maybe MeetSlice) - } - deriving (Eq, Show) - --- | Lenses for the PreserveAspectRatio type -makeClassy ''PreserveAspectRatio - -instance WithDefaultSvg PreserveAspectRatio where - defaultSvg = PreserveAspectRatio - { _aspectRatioDefer = False - , _aspectRatioAlign = AlignxMidYMid - , _aspectRatioMeetSlice = Nothing - } - --- | Describe how the line should be terminated --- when stroking them. Describe the values of the --- `stroke-linecap` attribute. --- See `_strokeLineCap` -data Cap - = CapRound -- ^ End with a round (`round` value) - | CapButt -- ^ Define straight just at the end (`butt` value) - | CapSquare -- ^ Straight further of the ends (`square` value) - deriving (Eq, Show) - --- | Define the possible values of the `stroke-linejoin` --- attribute. --- see `_strokeLineJoin` -data LineJoin - = JoinMiter -- ^ `miter` value - | JoinBevel -- ^ `bevel` value - | JoinRound -- ^ `round` value - deriving (Eq, Show) - --- | Describe the different value which can be used --- in the `fill` or `stroke` attributes. -data Texture - = ColorRef PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb) - | TextureRef String -- ^ Link to a complex texture (url(#name)) - | FillNone -- ^ Equivalent to the `none` value. - deriving (Eq, Show) - --- | Describe the possile filling algorithms. --- Map the values of the `fill-rule` attributes. -data FillRule - = FillEvenOdd -- ^ Correspond to the `evenodd` value. - | FillNonZero -- ^ Correspond to the `nonzero` value. - deriving (Eq, Show) - --- | Describe the content of the `transformation` attribute. --- see `_transform` and `transform`. -data Transformation - = -- | Directly encode the translation matrix. - TransformMatrix !Coord !Coord !Coord - !Coord !Coord !Coord - -- | Translation along a vector - | Translate !Double !Double - -- | Scaling on both axis or on X axis and Y axis. - | Scale !Double !(Maybe Double) - -- | Rotation around `(0, 0)` or around an optional - -- point. - | Rotate !Double !(Maybe (Double, Double)) - -- | Skew transformation along the X axis. - | SkewX !Double - -- | Skew transformation along the Y axis. - | SkewY !Double - -- | Unkown transformation, like identity. - | TransformUnknown - deriving (Eq, Show) - --- | Convert the Transformation to a string which can be --- directly used in a svg attributes. -serializeTransformation :: Transformation -> String -serializeTransformation t = case t of - TransformUnknown -> "" - TransformMatrix a b c d e f -> - printf "matrix(%g, %g, %g, %g, %g, %g)" a b c d e f - Translate x y -> printf "translate(%g, %g)" x y - Scale x Nothing -> printf "scale(%g)" x - Scale x (Just y) -> printf "scale(%g, %g)" x y - Rotate angle Nothing -> printf "rotate(%g)" angle - Rotate angle (Just (x, y))-> printf "rotate(%g, %g, %g)" angle x y - SkewX x -> printf "skewX(%g)" x - SkewY y -> printf "skewY(%g)" y - --- | Transform a list of transformations to a string for svg --- `transform` attributes. -serializeTransformations :: [Transformation] -> String -serializeTransformations = - unwords . fmap serializeTransformation - --- | Class helping find the drawing attributes for all --- the SVG attributes. -class WithDrawAttributes a where - -- | Lens which can be used to read/write primitives. - drawAttr :: Lens' a DrawAttributes - --- | Define an empty 'default' element for the SVG tree. --- It is used as base when parsing the element from XML. -class WithDefaultSvg a where - -- | The default element. - defaultSvg :: a - --- | Classify the font style, used to search a matching --- font in the FontCache. -data FontStyle - = FontStyleNormal - | FontStyleItalic - | FontStyleOblique - deriving (Eq, Show) - --- | Tell where to anchor the text, where the position --- given is realative to the text. -data TextAnchor - -- | The text with left aligned, or start at the postion - -- If the point is the '*' then the text will be printed - -- this way: - -- - -- > *THE_TEXT_TO_PRINT - -- - -- Equivalent to the `start` value. - = TextAnchorStart - -- | The text is middle aligned, so the text will be at - -- the left and right of the position: - -- - -- > THE_TEXT*TO_PRINT - -- - -- Equivalent to the `middle` value. - | TextAnchorMiddle - -- | The text is right aligned. - -- - -- > THE_TEXT_TO_PRINT* - -- - -- Equivalent to the `end` value. - | TextAnchorEnd - deriving (Eq, Show) - - --- | Correspond to the possible values of the --- the attributes which are either `none` or --- `url(#elem)` -data ElementRef - = RefNone -- ^ Value for `none` - | Ref String -- ^ Equivalent to `url()` attribute. - deriving (Eq, Show) - --- | This type define how to draw any primitives, --- which color to use, how to stroke the primitives --- and the potential transformations to use. --- --- All these attributes are propagated to the children. -data DrawAttributes = DrawAttributes - { -- | Attribute corresponding to the `stroke-width` - -- SVG attribute. - _strokeWidth :: !(Last Number) - -- | Correspond to the `stroke` attribute. - , _strokeColor :: !(Last Texture) - -- | Define the `stroke-opacity` attribute, the transparency - -- for the "border". - , _strokeOpacity :: !(Maybe Float) - -- | Correspond to the `stroke-linecap` SVG - -- attribute - , _strokeLineCap :: !(Last Cap) - -- | Correspond to the `stroke-linejoin` SVG - -- attribute - , _strokeLineJoin :: !(Last LineJoin) - -- | Define the distance of the miter join, correspond - -- to the `stroke-miterlimit` attritbue. - , _strokeMiterLimit :: !(Last Double) - -- | Define the filling color of the elements. Corresponding - -- to the `fill` attribute. - , _fillColor :: !(Last Texture) - -- | Define the `fill-opacity` attribute, the transparency - -- for the "content". - , _fillOpacity :: !(Maybe Float) - -- | Define the global or group opacity attribute. - , _groupOpacity :: !(Maybe Float) - -- | Content of the `transform` attribute - , _transform :: !(Maybe [Transformation]) - -- | Define the `fill-rule` used during the rendering. - , _fillRule :: !(Last FillRule) - -- | Define the `mask` attribute. - , _maskRef :: !(Last ElementRef) - -- | Define the `clip-path` attribute. - , _clipPathRef :: !(Last ElementRef) - -- | Define the `clip-rule` attribute. - , _clipRule :: !(Last FillRule) - -- | Map to the `class` attribute. Used for the CSS - -- rewriting. - , _attrClass :: ![T.Text] - -- | Map to the `id` attribute. Used for the CSS - -- rewriting. - , _attrId :: !(Maybe String) - -- | Define the start distance of the dashing pattern. - -- Correspond to the `stroke-dashoffset` attribute. - , _strokeOffset :: !(Last Number) - -- | Define the dashing pattern for the lines. Correspond - -- to the `stroke-dasharray` attribute. - , _strokeDashArray :: !(Last [Number]) - -- | Current size of the text, correspond to the - -- `font-size` SVG attribute. - , _fontSize :: !(Last Number) - -- | Define the possible fonts to be used for text rendering. - -- Map to the `font-family` attribute. - , _fontFamily :: !(Last [String]) - -- | Map to the `font-style` attribute. - , _fontStyle :: !(Last FontStyle) - -- | Define how to interpret the text position, correspond - -- to the `text-anchor` attribute. - , _textAnchor :: !(Last TextAnchor) - -- | Define the marker used for the start of the line. - -- Correspond to the `marker-start` attribute. - , _markerStart :: !(Last ElementRef) - -- | Define the marker used for every point of the - -- polyline/path Correspond to the `marker-mid` - -- attribute. - , _markerMid :: !(Last ElementRef) - -- | Define the marker used for the end of the line. - -- Correspond to the `marker-end` attribute. - , _markerEnd :: !(Last ElementRef) - } - deriving (Eq, Show) - --- | Lenses for the DrawAttributes type. -makeClassy ''DrawAttributes - --- | This primitive describe an unclosed suite of --- segments. Correspond to the `` tag. -data PolyLine = PolyLine - { -- | drawing attributes of the polyline. - _polyLineDrawAttributes :: !DrawAttributes - - -- | Geometry definition of the polyline. - -- correspond to the `points` attribute - , _polyLinePoints :: ![RPoint] - } - deriving (Eq, Show) - --- | Lenses for the PolyLine type. -makeClassy ''PolyLine - -instance WithDefaultSvg PolyLine where - defaultSvg = PolyLine - { _polyLineDrawAttributes = mempty - , _polyLinePoints = [] - } - - -instance WithDrawAttributes PolyLine where - drawAttr = polyLineDrawAttributes - --- | Primitive decriving polygon composed --- of segements. Correspond to the `` --- tag -data Polygon = Polygon - { -- | Drawing attributes for the polygon. - _polygonDrawAttributes :: !DrawAttributes - -- | Points of the polygon. Correspond to - -- the `points` attributes. - , _polygonPoints :: ![RPoint] - } - deriving (Eq, Show) - --- | Lenses for the Polygon type -makeClassy ''Polygon - -instance WithDrawAttributes Polygon where - drawAttr = polygonDrawAttributes - -instance WithDefaultSvg Polygon where - defaultSvg = Polygon - { _polygonDrawAttributes = mempty - , _polygonPoints = [] - } - --- | Define a simple line. Correspond to the --- `` tag. -data Line = Line - { -- | Drawing attributes of line. - _lineDrawAttributes :: !DrawAttributes - -- | First point of the the line, correspond - -- to the `x1` and `y1` attributes. - , _linePoint1 :: !Point - -- | Second point of the the line, correspond - -- to the `x2` and `y2` attributes. - , _linePoint2 :: !Point - } - deriving (Eq, Show) - --- | Lenses for the Line type. -makeClassy ''Line - -instance WithDrawAttributes Line where - drawAttr = lineDrawAttributes - -instance WithDefaultSvg Line where - defaultSvg = Line - { _lineDrawAttributes = mempty - , _linePoint1 = zeroPoint - , _linePoint2 = zeroPoint - } - where zeroPoint = (Num 0, Num 0) - --- | Define a rectangle. Correspond to --- `` svg tag. -data Rectangle = Rectangle - { -- | Rectangle drawing attributes. - _rectDrawAttributes :: !DrawAttributes - -- | Upper left corner of the rectangle, correspond - -- to the attributes `x` and `y`. - , _rectUpperLeftCorner :: !Point - -- | Rectangle width, correspond, strangely, to - -- the `width` attribute. - , _rectWidth :: !Number - -- | Rectangle height, correspond, amazingly, to - -- the `height` attribute. - , _rectHeight :: !Number - -- | Define the rounded corner radius radius - -- of the rectangle. Correspond to the `rx` and - -- `ry` attributes. - , _rectCornerRadius :: !(Number, Number) - } - deriving (Eq, Show) - --- | Lenses for the Rectangle type. -makeClassy ''Rectangle - -instance WithDrawAttributes Rectangle where - drawAttr = rectDrawAttributes - -instance WithDefaultSvg Rectangle where - defaultSvg = Rectangle - { _rectDrawAttributes = mempty - , _rectUpperLeftCorner = (Num 0, Num 0) - , _rectWidth = Num 0 - , _rectHeight = Num 0 - , _rectCornerRadius = (Num 0, Num 0) - } - --- | Type mapping the `` svg tag. -data Path = Path - { -- | Drawing attributes of the path. - _pathDrawAttributes :: !DrawAttributes - -- | Definition of the path, correspond to the - -- `d` attributes. - , _pathDefinition :: ![PathCommand] - } - deriving (Eq, Show) - --- | Lenses for the Path type -makeClassy ''Path - -instance WithDrawAttributes Path where - drawAttr = pathDrawAttributes - -instance WithDefaultSvg Path where - defaultSvg = Path - { _pathDrawAttributes = mempty - , _pathDefinition = [] - } - --- | Define a SVG group, corresponding `` tag. -data Group a = Group - { -- | Group drawing attributes, propagated to all of its - -- children. - _groupDrawAttributes :: !DrawAttributes - -- | Content of the group, corresponding to all the tags - -- inside the `` tag. - , _groupChildren :: ![a] - -- | Mapped to the attribute `viewBox` - , _groupViewBox :: !(Maybe (Double, Double, Double, Double)) - -- | used for symbols only - , _groupAspectRatio :: !PreserveAspectRatio - } - deriving (Eq, Show) - --- | Lenses associated to the Group type. -makeClassy ''Group - -instance WithDrawAttributes (Group a) where - drawAttr = groupDrawAttributes - -instance WithDefaultSvg (Group a) where - defaultSvg = Group - { _groupDrawAttributes = mempty - , _groupChildren = [] - , _groupViewBox = Nothing - , _groupAspectRatio = defaultSvg - } - --- | Define the `` tag, equivalent to --- a named group. -newtype Symbol a = - Symbol { _groupOfSymbol :: Group a } - deriving (Eq, Show) - --- | Lenses associated with the Symbol type. -makeLenses ''Symbol - -instance WithDrawAttributes (Symbol a) where - drawAttr = groupOfSymbol . drawAttr - -instance WithDefaultSvg (Symbol a) where - defaultSvg = Symbol defaultSvg - --- | Define a ``. -data Circle = Circle - { -- | Drawing attributes of the circle. - _circleDrawAttributes :: !DrawAttributes - -- | Define the center of the circle, describe - -- the `cx` and `cy` attributes. - , _circleCenter :: !Point - -- | Radius of the circle, equivalent to the `r` - -- attribute. - , _circleRadius :: !Number - } - deriving (Eq, Show) - --- | Lenses for the Circle type. -makeClassy ''Circle - -instance WithDrawAttributes Circle where - drawAttr = circleDrawAttributes - -instance WithDefaultSvg Circle where - defaultSvg = Circle - { _circleDrawAttributes = mempty - , _circleCenter = (Num 0, Num 0) - , _circleRadius = Num 0 - } - --- | Define an `` -data Ellipse = Ellipse - { -- | Drawing attributes of the ellipse. - _ellipseDrawAttributes :: !DrawAttributes - -- | Center of the ellipse, map to the `cx` - -- and `cy` attributes. - , _ellipseCenter :: !Point - -- | Radius along the X axis, map the - -- `rx` attribute. - , _ellipseXRadius :: !Number - -- | Radius along the Y axis, map the - -- `ry` attribute. - , _ellipseYRadius :: !Number - } - deriving (Eq, Show) - --- | Lenses for the ellipse type. -makeClassy ''Ellipse - -instance WithDrawAttributes Ellipse where - drawAttr = ellipseDrawAttributes - -instance WithDefaultSvg Ellipse where - defaultSvg = Ellipse - { _ellipseDrawAttributes = mempty - , _ellipseCenter = (Num 0, Num 0) - , _ellipseXRadius = Num 0 - , _ellipseYRadius = Num 0 - } - --- | Define an `` tag. -data Image = Image - { -- | Drawing attributes of the image - _imageDrawAttributes :: !DrawAttributes - -- | Position of the image referenced by its - -- upper left corner. - , _imageCornerUpperLeft :: !Point - -- | Image width - , _imageWidth :: !Number - -- | Image Height - , _imageHeight :: !Number - -- | Image href, pointing to the real image. - , _imageHref :: !String - -- | preserveAspectRatio attribute - , _imageAspectRatio :: !PreserveAspectRatio - } - deriving (Eq, Show) - --- | Lenses for the Image type. -makeClassy ''Image - -instance WithDrawAttributes Image where - drawAttr = imageDrawAttributes - -instance WithDefaultSvg Image where - defaultSvg = Image - { _imageDrawAttributes = mempty - , _imageCornerUpperLeft = (Num 0, Num 0) - , _imageWidth = Num 0 - , _imageHeight = Num 0 - , _imageHref = "" - , _imageAspectRatio = defaultSvg - } - --- | Define an `` for a named content. --- Every named content can be reused in the --- document using this element. -data Use = Use - { -- | Position where to draw the "used" element. - -- Correspond to the `x` and `y` attributes. - _useBase :: Point - -- | Referenced name, correspond to `xlink:href` - -- attribute. - , _useName :: String - -- | Define the width of the region where - -- to place the element. Map to the `width` - -- attribute. - , _useWidth :: Maybe Number - -- | Define the height of the region where - -- to place the element. Map to the `height` - -- attribute. - , _useHeight :: Maybe Number - -- | Use draw attributes. - , _useDrawAttributes :: DrawAttributes - } - deriving (Eq, Show) - --- | Lenses for the Use type. -makeClassy ''Use - -instance WithDrawAttributes Use where - drawAttr = useDrawAttributes - -instance WithDefaultSvg Use where - defaultSvg = Use - { _useBase = (Num 0, Num 0) - , _useName = "" - , _useWidth = Nothing - , _useHeight = Nothing - , _useDrawAttributes = mempty - } - --- | Define position information associated to --- `` or `` svg tag. -data TextInfo = TextInfo - { _textInfoX :: ![Number] -- ^ `x` attribute. - , _textInfoY :: ![Number] -- ^ `y` attribute. - , _textInfoDX :: ![Number] -- ^ `dx` attribute. - , _textInfoDY :: ![Number] -- ^ `dy` attribute. - , _textInfoRotate :: ![Double] -- ^ `rotate` attribute. - , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute. - } - deriving (Eq, Show) - -instance Monoid TextInfo where - mempty = TextInfo [] [] [] [] [] Nothing - mappend (TextInfo x1 y1 dx1 dy1 r1 l1) - (TextInfo x2 y2 dx2 dy2 r2 l2) = - TextInfo (x1 <> x2) (y1 <> y2) - (dx1 <> dx2) (dy1 <> dy2) - (r1 <> r2) - (getLast $ Last l1 <> Last l2) - --- | Lenses for the TextInfo type. -makeClassy ''TextInfo - -instance WithDefaultSvg TextInfo where - defaultSvg = mempty - --- | Define the content of a `` tag. -data TextSpanContent - = SpanText !T.Text -- ^ Raw text - | SpanTextRef !String -- ^ Equivalent to a `` - | SpanSub !TextSpan -- ^ Define a `` - deriving (Eq, Show) - --- | Define a `` tag. -data TextSpan = TextSpan - { -- | Placing information for the text. - _spanInfo :: !TextInfo - -- | Drawing attributes for the text span. - , _spanDrawAttributes :: !DrawAttributes - -- | Content of the span. - , _spanContent :: ![TextSpanContent] - } - deriving (Eq, Show) - --- | Lenses for the TextSpan type. -makeClassy ''TextSpan - -instance WithDefaultSvg TextSpan where - defaultSvg = TextSpan - { _spanInfo = defaultSvg - , _spanDrawAttributes = mempty - , _spanContent = mempty - } - --- | Describe the content of the `method` attribute on --- text path. -data TextPathMethod - = TextPathAlign -- ^ Map to the `align` value. - | TextPathStretch -- ^ Map to the `stretch` value. - deriving (Eq, Show) - --- | Describe the content of the `spacing` text path --- attribute. -data TextPathSpacing - = TextPathSpacingExact -- ^ Map to the `exact` value. - | TextPathSpacingAuto -- ^ Map to the `auto` value. - deriving (Eq, Show) - --- | Describe the `` SVG tag. -data TextPath = TextPath - { -- | Define the beginning offset on the path, - -- the `startOffset` attribute. - _textPathStartOffset :: !Number - -- | Define the `xlink:href` attribute. - , _textPathName :: !String - -- | Correspond to the `method` attribute. - , _textPathMethod :: !TextPathMethod - -- | Correspond to the `spacing` attribute. - , _textPathSpacing :: !TextPathSpacing - -- | Real content of the path. - , _textPathData :: ![PathCommand] - } - deriving (Eq, Show) - --- | Lenses for the TextPath type. -makeClassy ''TextPath - -instance WithDefaultSvg TextPath where - defaultSvg = TextPath - { _textPathStartOffset = Num 0 - , _textPathName = mempty - , _textPathMethod = TextPathAlign - , _textPathSpacing = TextPathSpacingExact - , _textPathData = [] - } - --- | Define the possible values of the `lengthAdjust` --- attribute. -data TextAdjust - = TextAdjustSpacing -- ^ Value `spacing` - | TextAdjustSpacingAndGlyphs -- ^ Value `spacingAndGlyphs` - deriving (Eq, Show) - --- | Define the global `` SVG tag. -data Text = Text - { -- | Define the `lengthAdjust` attribute. - _textAdjust :: !TextAdjust - -- | Root of the text content. - , _textRoot :: !TextSpan - } - deriving (Eq, Show) - --- | Lenses for the Text type. -makeClassy ''Text - --- | Little helper to create a SVG text at a given --- baseline position. -textAt :: Point -> T.Text -> Text -textAt (x, y) txt = Text TextAdjustSpacing tspan where - tspan = defaultSvg - { _spanContent = [SpanText txt] - , _spanInfo = defaultSvg - { _textInfoX = [x] - , _textInfoY = [y] - } - } - -instance WithDrawAttributes Text where - drawAttr = textRoot . spanDrawAttributes - -instance WithDefaultSvg Text where - defaultSvg = Text - { _textRoot = defaultSvg - , _textAdjust = TextAdjustSpacing - } - --- | Main type for the scene description, reorient to --- specific type describing each tag. -data Tree - = None - | UseTree { useInformation :: !Use - , useSubTree :: !(Maybe Tree) } - | GroupTree !(Group Tree) - | SymbolTree !(Symbol Tree) - | PathTree !Path - | CircleTree !Circle - | PolyLineTree !PolyLine - | PolygonTree !Polygon - | EllipseTree !Ellipse - | LineTree !Line - | RectangleTree !Rectangle - | TextTree !(Maybe TextPath) !Text - | ImageTree !Image - deriving (Eq, Show) - --- | Define the orientation, associated to the --- `orient` attribute on the Marker -data MarkerOrientation - = OrientationAuto -- ^ Auto value - | OrientationAngle Coord -- ^ Specific angle. - deriving (Eq, Show) - --- | Define the content of the `markerUnits` attribute --- on the Marker. -data MarkerUnit - = MarkerUnitStrokeWidth -- ^ Value `strokeWidth` - | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse` - deriving (Eq, Show) - --- | Define the content of the `markerUnits` attribute --- on the Marker. -data Overflow - = OverflowVisible -- ^ Value `visible` - | OverflowHidden -- ^ Value `hidden` - deriving (Eq, Show) - --- | Define the `` tag. -data Marker = Marker - { -- | Draw attributes of the marker. - _markerDrawAttributes :: DrawAttributes - -- | Define the reference point of the marker. - -- correspond to the `refX` and `refY` attributes. - , _markerRefPoint :: !(Number, Number) - -- | Define the width of the marker. Correspond to - -- the `markerWidth` attribute. - , _markerWidth :: !(Maybe Number) - -- | Define the height of the marker. Correspond to - -- the `markerHeight` attribute. - , _markerHeight :: !(Maybe Number) - -- | Correspond to the `orient` attribute. - , _markerOrient :: !(Maybe MarkerOrientation) - -- | Map the `markerUnits` attribute. - , _markerUnits :: !(Maybe MarkerUnit) - -- | Optional viewbox - , _markerViewBox :: !(Maybe (Double, Double, Double, Double)) - -- | Elements defining the marker. - , _markerOverflow :: !(Maybe Overflow) - -- | preserveAspectRatio attribute - , _markerAspectRatio :: !PreserveAspectRatio - -- | Elements defining the marker. - , _markerElements :: [Tree] - } - deriving (Eq, Show) - --- | Lenses for the Marker type. -makeClassy ''Marker - -instance WithDrawAttributes Marker where - drawAttr = markerDrawAttributes - -instance WithDefaultSvg Marker where - defaultSvg = Marker - { _markerDrawAttributes = mempty - , _markerRefPoint = (Num 0, Num 0) - , _markerWidth = Just (Num 3) - , _markerHeight = Just (Num 3) - , _markerOrient = Nothing -- MarkerOrientation - , _markerUnits = Nothing -- MarkerUnitStrokeWidth - , _markerViewBox = Nothing - , _markerOverflow = Nothing - , _markerElements = mempty - , _markerAspectRatio = defaultSvg - } - --- | Insert element in the first sublist in the list of list. -appNode :: [[a]] -> a -> [[a]] -appNode [] e = [[e]] -appNode (curr:above) e = (e:curr) : above - --- | Map a tree while propagating context information. --- The function passed in parameter receive a list --- representing the the path used to go arrive to the --- current node. -zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree -zipTree f = dig [] where - dig prev e@None = f $ appNode prev e - dig prev e@(UseTree _ Nothing) = f $ appNode prev e - dig prev e@(UseTree nfo (Just u)) = - f . appNode prev . UseTree nfo . Just $ dig ([] : appNode prev e) u - dig prev e@(GroupTree g) = - f . appNode prev . GroupTree $ zipGroup (appNode prev e) g - dig prev e@(SymbolTree g) = - f . appNode prev . SymbolTree . Symbol . - zipGroup (appNode prev e) $ _groupOfSymbol g - dig prev e@(PathTree _) = f $ appNode prev e - dig prev e@(CircleTree _) = f $ appNode prev e - dig prev e@(PolyLineTree _) = f $ appNode prev e - dig prev e@(PolygonTree _) = f $ appNode prev e - dig prev e@(EllipseTree _) = f $ appNode prev e - dig prev e@(LineTree _) = f $ appNode prev e - dig prev e@(RectangleTree _) = f $ appNode prev e - dig prev e@(TextTree _ _) = f $ appNode prev e - dig prev e@(ImageTree _) = f $ appNode prev e - - zipGroup prev g = g { _groupChildren = updatedChildren } - where - groupChild = _groupChildren g - updatedChildren = - [dig (c:prev) child - | (child, c) <- zip groupChild $ inits groupChild] - --- | Fold all nodes of a SVG tree. -foldTree :: (a -> Tree -> a) -> a -> Tree -> a -foldTree f = go where - go acc e = case e of - None -> f acc e - UseTree _ _ -> f acc e - PathTree _ -> f acc e - CircleTree _ -> f acc e - PolyLineTree _ -> f acc e - PolygonTree _ -> f acc e - EllipseTree _ -> f acc e - LineTree _ -> f acc e - RectangleTree _ -> f acc e - TextTree _ _ -> f acc e - ImageTree _ -> f acc e - GroupTree g -> - let subAcc = F.foldl' go acc $ _groupChildren g in - f subAcc e - SymbolTree s -> - let subAcc = - F.foldl' go acc . _groupChildren $ _groupOfSymbol s in - f subAcc e - --- | Helper function mapping every tree element. -mapTree :: (Tree -> Tree) -> Tree -> Tree -mapTree f = go where - go e@None = f e - go e@(UseTree _ _) = f e - go (GroupTree g) = f . GroupTree $ mapGroup g - go (SymbolTree g) = - f . SymbolTree . Symbol . mapGroup $ _groupOfSymbol g - go e@(PathTree _) = f e - go e@(CircleTree _) = f e - go e@(PolyLineTree _) = f e - go e@(PolygonTree _) = f e - go e@(EllipseTree _) = f e - go e@(LineTree _) = f e - go e@(RectangleTree _) = f e - go e@(TextTree _ _) = f e - go e@(ImageTree _) = f e - - mapGroup g = - g { _groupChildren = map go $ _groupChildren g } - --- | For every element of a svg tree, associate --- it's SVG tag name. -nameOfTree :: Tree -> T.Text -nameOfTree v = - case v of - None -> "" - UseTree _ _ -> "use" - GroupTree _ -> "g" - SymbolTree _ -> "symbol" - PathTree _ -> "path" - CircleTree _ -> "circle" - PolyLineTree _ -> "polyline" - PolygonTree _ -> "polygon" - EllipseTree _ -> "ellipse" - LineTree _ -> "line" - RectangleTree _ -> "rectangle" - TextTree _ _ -> "text" - ImageTree _ -> "image" - -drawAttrOfTree :: Tree -> DrawAttributes -drawAttrOfTree v = case v of - None -> mempty - UseTree e _ -> e ^. drawAttr - GroupTree e -> e ^. drawAttr - SymbolTree e -> e ^. drawAttr - PathTree e -> e ^. drawAttr - CircleTree e -> e ^. drawAttr - PolyLineTree e -> e ^. drawAttr - PolygonTree e -> e ^. drawAttr - EllipseTree e -> e ^. drawAttr - LineTree e -> e ^. drawAttr - RectangleTree e -> e ^. drawAttr - TextTree _ e -> e ^. drawAttr - ImageTree e -> e ^. drawAttr - -setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree -setDrawAttrOfTree v attr = case v of - None -> None - UseTree e m -> UseTree (e & drawAttr .~ attr) m - GroupTree e -> GroupTree $ e & drawAttr .~ attr - SymbolTree e -> SymbolTree $ e & drawAttr .~ attr - PathTree e -> PathTree $ e & drawAttr .~ attr - CircleTree e -> CircleTree $ e & drawAttr .~ attr - PolyLineTree e -> PolyLineTree $ e & drawAttr .~ attr - PolygonTree e -> PolygonTree $ e & drawAttr .~ attr - EllipseTree e -> EllipseTree $ e & drawAttr .~ attr - LineTree e -> LineTree $ e & drawAttr .~ attr - RectangleTree e -> RectangleTree $ e & drawAttr .~ attr - TextTree a e -> TextTree a $ e & drawAttr .~ attr - ImageTree e -> ImageTree $ e & drawAttr .~ attr - -instance WithDrawAttributes Tree where - drawAttr = lens drawAttrOfTree setDrawAttrOfTree - -instance WithDefaultSvg Tree where - defaultSvg = None - --- | Define the possible values of various *units attributes --- used in the definition of the gradients and masks. -data CoordinateUnits - = CoordUserSpace -- ^ `userSpaceOnUse` value - | CoordBoundingBox -- ^ `objectBoundingBox` value - deriving (Eq, Show) - --- | Define the possible values for the `spreadMethod` --- values used for the gradient definitions. -data Spread - = SpreadRepeat -- ^ `reapeat` value - | SpreadPad -- ^ `pad` value - | SpreadReflect -- ^ `reflect value` - deriving (Eq, Show) - --- | Define a color stop for the gradients. Represent --- the `` SVG tag. -data GradientStop = GradientStop - { -- | Gradient offset between 0 and 1, correspond - -- to the `offset` attribute. - _gradientOffset :: Float - -- | Color of the gradient stop. Correspond - -- to the `stop-color` attribute. - , _gradientColor :: PixelRGBA8 - } - deriving (Eq, Show) - --- | Lenses for the GradientStop type. -makeClassy ''GradientStop - -instance WithDefaultSvg GradientStop where - defaultSvg = GradientStop - { _gradientOffset = 0.0 - , _gradientColor = PixelRGBA8 0 0 0 255 - } - --- | Define a `` tag. -data LinearGradient = LinearGradient - { -- | Define coordinate system of the gradient, - -- associated to the `gradientUnits` attribute. - _linearGradientUnits :: CoordinateUnits - -- | Point defining the beginning of the line gradient. - -- Associated to the `x1` and `y1` attribute. - , _linearGradientStart :: Point - -- | Point defining the end of the line gradient. - -- Associated to the `x2` and `y2` attribute. - , _linearGradientStop :: Point - -- | Define how to handle the values outside - -- the gradient start and stop. Associated to the - -- `spreadMethod` attribute. - , _linearGradientSpread :: Spread - -- | Define the transformation to apply to the - -- gradient points. Associated to the `gradientTransform` - -- attribute. - , _linearGradientTransform :: [Transformation] - -- | List of color stops of the linear gradient. - , _linearGradientStops :: [GradientStop] - } - deriving (Eq, Show) - --- | Lenses for the LinearGradient type. -makeClassy ''LinearGradient - -instance WithDefaultSvg LinearGradient where - defaultSvg = LinearGradient - { _linearGradientUnits = CoordBoundingBox - , _linearGradientStart = (Percent 0, Percent 0) - , _linearGradientStop = (Percent 1, Percent 0) - , _linearGradientSpread = SpreadPad - , _linearGradientTransform = [] - , _linearGradientStops = [] - } - --- | Define a `` tag. -data RadialGradient = RadialGradient - { -- | Define coordinate system of the gradient, - -- associated to the `gradientUnits` attribute. - _radialGradientUnits :: CoordinateUnits - -- | Center of the radial gradient. Associated to - -- the `cx` and `cy` attributes. - , _radialGradientCenter :: Point - -- | Radius of the radial gradient. Associated to - -- the `r` attribute. - , _radialGradientRadius :: Number - -- | X coordinate of the focus point of the radial - -- gradient. Associated to the `fx` attribute. - , _radialGradientFocusX :: Maybe Number - -- | Y coordinate of the focus point of the radial - -- gradient. Associated to the `fy` attribute. - , _radialGradientFocusY :: Maybe Number - -- | Define how to handle the values outside - -- the gradient start and stop. Associated to the - -- `spreadMethod` attribute. - , _radialGradientSpread :: Spread - -- | Define the transformation to apply to the - -- gradient points. Associated to the `gradientTransform` - -- attribute. - , _radialGradientTransform :: [Transformation] - -- | List of color stops of the radial gradient. - , _radialGradientStops :: [GradientStop] - } - deriving (Eq, Show) - --- | Lenses for the RadialGradient type. -makeClassy ''RadialGradient - -instance WithDefaultSvg RadialGradient where - defaultSvg = RadialGradient - { _radialGradientUnits = CoordBoundingBox - , _radialGradientCenter = (Percent 0.5, Percent 0.5) - , _radialGradientRadius = Percent 0.5 - , _radialGradientFocusX = Nothing - , _radialGradientFocusY = Nothing - , _radialGradientSpread = SpreadPad - , _radialGradientTransform = [] - , _radialGradientStops = [] - } - --- | Define a SVG `` tag. -data Mask = Mask - { -- | Drawing attributes of the Mask - _maskDrawAttributes :: DrawAttributes - -- | Correspond to the `maskContentUnits` attributes. - , _maskContentUnits :: CoordinateUnits - -- | Mapping to the `maskUnits` attribute. - , _maskUnits :: CoordinateUnits - -- | Map to the `x` and `y` attributes. - , _maskPosition :: Point - -- | Map to the `width` attribute - , _maskWidth :: Number - -- | Map to the `height` attribute. - , _maskHeight :: Number - -- | Children of the `` tag. - , _maskContent :: [Tree] - } - deriving (Eq, Show) - --- | Lenses for the Mask type. -makeClassy ''Mask - -instance WithDrawAttributes Mask where - drawAttr = maskDrawAttributes - -instance WithDefaultSvg Mask where - defaultSvg = Mask - { _maskDrawAttributes = mempty - , _maskContentUnits = CoordUserSpace - , _maskUnits = CoordBoundingBox - , _maskPosition = (Percent (-0.1), Percent (-0.1)) - , _maskWidth = Percent 1.2 - , _maskHeight = Percent 1.2 - , _maskContent = [] - } - --- | Define a `` tag. -data ClipPath = ClipPath - { _clipPathDrawAttributes :: DrawAttributes - -- | Maps to the `clipPathUnits` attribute - , _clipPathUnits :: CoordinateUnits - -- | Maps to the content of the tree - , _clipPathContent :: [Tree] - } - deriving (Eq, Show) - --- | Lenses for the ClipPath type. -makeClassy ''ClipPath - -instance WithDrawAttributes ClipPath where - drawAttr = clipPathDrawAttributes - -instance WithDefaultSvg ClipPath where - defaultSvg = ClipPath - { _clipPathDrawAttributes = mempty - , _clipPathUnits = CoordUserSpace - , _clipPathContent = mempty - } - --- | Define a `` tag. -data Pattern = Pattern - { -- | Pattern drawing attributes. - _patternDrawAttributes :: !DrawAttributes - -- | Possible `viewBox`. - , _patternViewBox :: !(Maybe (Double, Double, Double, Double)) - -- | Width of the pattern tile, mapped to the - -- `width` attribute - , _patternWidth :: !Number - -- | Height of the pattern tile, mapped to the - -- `height` attribute - , _patternHeight :: !Number - -- | Pattern tile base, mapped to the `x` and - -- `y` attributes. - , _patternPos :: !Point - -- | Elements used in the pattern. - , _patternElements :: ![Tree] - -- | Define the cordinate system to use for - -- the pattern. Mapped to the `patternUnits` - -- attribute. - , _patternUnit :: !CoordinateUnits - -- | Value of the "preserveAspectRatio" attribute - , _patternAspectRatio :: !PreserveAspectRatio - } - deriving Show - --- | Lenses for the Patter type. -makeClassy ''Pattern - -instance WithDrawAttributes Pattern where - drawAttr = patternDrawAttributes - -instance WithDefaultSvg Pattern where - defaultSvg = Pattern - { _patternViewBox = Nothing - , _patternWidth = Num 0 - , _patternHeight = Num 0 - , _patternPos = (Num 0, Num 0) - , _patternElements = [] - , _patternUnit = CoordBoundingBox - , _patternDrawAttributes = mempty - , _patternAspectRatio = defaultSvg - } - --- | Sum types helping keeping track of all the namable --- elemens in a SVG document. -data Element - = ElementLinearGradient LinearGradient - | ElementRadialGradient RadialGradient - | ElementGeometry Tree - | ElementPattern Pattern - | ElementMarker Marker - | ElementMask Mask - | ElementClipPath ClipPath - deriving Show - --- | Represent a full svg document with style, --- geometry and named elements. -data Document = Document - { _viewBox :: Maybe (Double, Double, Double, Double) - , _width :: Maybe Number - , _height :: Maybe Number - , _elements :: [Tree] - , _definitions :: M.Map String Element - , _description :: String - , _styleRules :: [CssRule] - , _documentLocation :: FilePath - } - deriving Show - --- | Lenses associated to a SVG document. -makeClassy ''Document - --- | Calculate the document size in function of the --- different available attributes in the document. -documentSize :: Dpi -> Document -> (Int, Int) -documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) - , _width = Just (Percent pw) - , _height = Just (Percent ph) - } = - (floor $ dx * pw, floor $ dy * ph) - where - dx = abs $ x2 - x1 - dy = abs $ y2 - y1 -documentSize _ Document { _width = Just (Num w) - , _height = Just (Num h) } = (floor w, floor h) -documentSize dpi doc@(Document { _width = Just w - , _height = Just h }) = - documentSize dpi $ doc - { _width = Just $ toUserUnit dpi w - , _height = Just $ toUserUnit dpi h } -documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } = - (floor . abs $ x2 - x1, floor . abs $ y2 - y1) -documentSize _ _ = (1, 1) - -mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a -mayMerge (Just a) (Just b) = Just $ mappend a b -mayMerge _ b@(Just _) = b -mayMerge a Nothing = a - -instance Monoid DrawAttributes where - mempty = DrawAttributes - { _strokeWidth = Last Nothing - , _strokeColor = Last Nothing - , _strokeOpacity = Nothing - , _strokeLineCap = Last Nothing - , _strokeLineJoin = Last Nothing - , _strokeMiterLimit = Last Nothing - , _fillColor = Last Nothing - , _groupOpacity = Nothing - , _fillOpacity = Nothing - , _fontSize = Last Nothing - , _fontFamily = Last Nothing - , _fontStyle = Last Nothing - , _transform = Nothing - , _fillRule = Last Nothing - , _attrClass = mempty - , _attrId = Nothing - , _strokeOffset = Last Nothing - , _strokeDashArray = Last Nothing - , _textAnchor = Last Nothing - , _maskRef = Last Nothing - , _clipPathRef = Last Nothing - , _clipRule = Last Nothing - - , _markerStart = Last Nothing - , _markerMid = Last Nothing - , _markerEnd = Last Nothing - } - - mappend a b = DrawAttributes - { _strokeWidth = (mappend `on` _strokeWidth) a b - , _strokeColor = (mappend `on` _strokeColor) a b - , _strokeLineCap = (mappend `on` _strokeLineCap) a b - , _strokeOpacity = (opacityMappend `on` _strokeOpacity) a b - , _strokeLineJoin = (mappend `on` _strokeLineJoin) a b - , _strokeMiterLimit = (mappend `on` _strokeMiterLimit) a b - , _fillColor = (mappend `on` _fillColor) a b - , _fillOpacity = (opacityMappend `on` _fillOpacity) a b - , _fontSize = (mappend `on` _fontSize) a b - , _transform = (mayMerge `on` _transform) a b - , _fillRule = (mappend `on` _fillRule) a b - , _attrClass = _attrClass b - , _attrId = _attrId b - , _groupOpacity = _groupOpacity b - , _strokeOffset = (mappend `on` _strokeOffset) a b - , _strokeDashArray = (mappend `on` _strokeDashArray) a b - , _fontFamily = (mappend `on` _fontFamily) a b - , _fontStyle = (mappend `on` _fontStyle) a b - , _textAnchor = (mappend `on` _textAnchor) a b - , _maskRef = (mappend `on` _maskRef) a b - , _clipPathRef = (mappend `on` _clipPathRef) a b - , _clipRule = (mappend `on` _clipRule) a b - , _markerStart = (mappend `on` _markerStart) a b - , _markerMid = (mappend `on` _markerMid) a b - , _markerEnd = (mappend `on` _markerEnd) a b - } - where - opacityMappend Nothing Nothing = Nothing - opacityMappend (Just v) Nothing = Just v - opacityMappend Nothing (Just v) = Just v - opacityMappend (Just v) (Just v2) = Just $ v * v2 - -instance WithDefaultSvg DrawAttributes where - defaultSvg = mempty - -instance CssMatcheable Tree where - cssAttribOf _ _ = Nothing - cssClassOf = view (drawAttr . attrClass) - cssIdOf = fmap T.pack . view (drawAttr . attrId) - cssNameOf = nameOfTree - +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +-- | This module define all the types used in the definition +-- of a svg scene. +-- +-- Most of the types are lensified. +module Graphics.Svg.Types + ( -- * Basic building types + Coord + , Origin( .. ) + , Point + , RPoint + , PathCommand( .. ) + , Transformation( .. ) + , ElementRef( .. ) + , CoordinateUnits( .. ) + + -- ** Building helpers + , toPoint + , serializeNumber + , serializeTransformation + , serializeTransformations + + -- * Drawing control types + , Cap( .. ) + , LineJoin( .. ) + , Tree( .. ) + , Number( .. ) + , Spread( .. ) + , Texture( .. ) + , Element( .. ) + , FillRule( .. ) + , FontStyle( .. ) + , Dpi + + , WithDefaultSvg( .. ) + + -- * Main type + , Document( .. ) + , HasDocument( .. ) + , documentSize + + -- * Drawing attributes + , DrawAttributes( .. ) + , HasDrawAttributes( .. ) + , WithDrawAttributes( .. ) + + -- * SVG drawing primitives + -- ** Rectangle + , Rectangle( .. ) + , HasRectangle( .. ) + + -- ** Line + , Line( .. ) + , HasLine( .. ) + + -- ** Polygon + , Polygon( .. ) + , HasPolygon( .. ) + + -- ** Polyline + , PolyLine( .. ) + , HasPolyLine( .. ) + + -- ** Path + , Path( .. ) + , HasPath( .. ) + + -- ** Circle + , Circle( .. ) + , HasCircle( .. ) + + -- ** Ellipse + , Ellipse( .. ) + , HasEllipse( .. ) + + -- ** Image + , Image( .. ) + , HasImage( .. ) + + -- ** Use + , Use( .. ) + , HasUse( .. ) + + -- * Grouping primitives + -- ** Group + , Group( .. ) + , HasGroup( .. ) + + -- ** Symbol + , Symbol( .. ) + , groupOfSymbol + + -- * Text related types + -- ** Text + , Text( .. ) + , HasText( .. ) + , TextAnchor( .. ) + , textAt + + -- ** Text path + , TextPath( .. ) + , HasTextPath( .. ) + + , TextPathSpacing( .. ) + , TextPathMethod( .. ) + + -- ** Text span. + , TextSpanContent( .. ) + + , TextSpan( .. ) + , HasTextSpan( .. ) + + , TextInfo( .. ) + , HasTextInfo( .. ) + + , TextAdjust( .. ) + + -- * Marker definition + , Marker( .. ) + , Overflow( .. ) + , MarkerOrientation( .. ) + , MarkerUnit( .. ) + , HasMarker( .. ) + + -- * Gradient definition + , GradientStop( .. ) + , HasGradientStop( .. ) + + -- ** Linear Gradient + , LinearGradient( .. ) + , HasLinearGradient( .. ) + + -- ** Radial Gradient + , RadialGradient( .. ) + , HasRadialGradient( .. ) + + -- * Pattern definition + , Pattern( .. ) + , HasPattern( .. ) + + -- * Mask definition + , Mask( .. ) + , HasMask( .. ) + + -- * Clip path definition + , ClipPath( .. ) + , HasClipPath( .. ) + + -- * Aspect Ratio description + , PreserveAspectRatio( .. ) + , Alignment( .. ) + , MeetSlice( .. ) + , HasPreserveAspectRatio( .. ) + + -- * MISC functions + , isPathArc + , isPathWithArc + , nameOfTree + , zipTree + , mapTree + , foldTree + , toUserUnit + , mapNumber + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid( .. ) ) +import Data.Foldable( Foldable ) +#endif + +import Data.Function( on ) +import Data.List( inits ) +import qualified Data.Map as M +import Data.Monoid( Last( .. ), (<>) ) +import qualified Data.Foldable as F +import qualified Data.Text as T +import Codec.Picture( PixelRGBA8( .. ) ) +import Control.Lens( Lens' + , lens + , makeClassy + , makeLenses + , view + , (^.) + , (&) + , (.~) + ) +import Graphics.Svg.CssTypes +import Linear hiding ( angle ) + +import Text.Printf + +-- | Basic coordiante type. +type Coord = Double + +-- | Real Point, fully determined and not +-- dependant of the rendering context. +type RPoint = V2 Coord + +-- | Possibly context dependant point. +type Point = (Number, Number) + +-- | Tell if a path command is absolute (in the current +-- user coordiante) or relative to the previous poitn. +data Origin + = OriginAbsolute -- ^ Next point in absolute coordinate + | OriginRelative -- ^ Next point relative to the previous + deriving (Eq, Show) + +-- | Path command definition. +data PathCommand + -- | 'M' or 'm' command + = MoveTo !Origin ![RPoint] + -- | Line to, 'L' or 'l' Svg path command. + | LineTo !Origin ![RPoint] + + -- | Equivalent to the 'H' or 'h' svg path command. + | HorizontalTo !Origin ![Coord] + -- | Equivalent to the 'V' or 'v' svg path command. + | VerticalTo !Origin ![Coord] + + -- | Cubic bezier, 'C' or 'c' command + | CurveTo !Origin ![(RPoint, RPoint, RPoint)] + -- | Smooth cubic bezier, equivalent to 'S' or 's' command + | SmoothCurveTo !Origin ![(RPoint, RPoint)] + -- | Quadratic bezier, 'Q' or 'q' command + | QuadraticBezier !Origin ![(RPoint, RPoint)] + -- | Quadratic bezier, 'T' or 't' command + | SmoothQuadraticBezierCurveTo !Origin ![RPoint] + -- | Eliptical arc, 'A' or 'a' command. + | EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)] + -- | Close the path, 'Z' or 'z' svg path command. + | EndPath + deriving (Eq, Show) + +-- | Little helper function to build a point. +toPoint :: Number -> Number -> Point +toPoint = (,) + +-- | Tell if the path command is an EllipticalArc. +isPathArc :: PathCommand -> Bool +isPathArc (EllipticalArc _ _) = True +isPathArc _ = False + +-- | Tell if a full path contain an EllipticalArc. +isPathWithArc :: Foldable f => f PathCommand -> Bool +isPathWithArc = F.any isPathArc + +-- | This type represent the align information of the +-- preserveAspectRatio SVGattribute +data Alignment + = AlignNone -- ^ "none" value + | AlignxMinYMin -- "xMinYMin" value + | AlignxMidYMin -- ^ "xMidYMin" value + | AlignxMaxYMin -- ^ "xMaxYMin" value + | AlignxMinYMid -- ^ "xMinYMid" value + | AlignxMidYMid -- ^ "xMidYMid" value + | AlignxMaxYMid -- ^ "xMaxYMid" value + | AlignxMinYMax -- ^ "xMinYMax" value + | AlignxMidYMax -- ^ "xMidYMax" value + | AlignxMaxYMax -- ^ "xMaxYMax" value + deriving (Eq, Show) + +-- | This type represent the "meet or slice" information +-- of the preserveAspectRatio SVGattribute +data MeetSlice = Meet | Slice + deriving (Eq, Show) + +-- | Describe the content of the preserveAspectRatio attribute. +data PreserveAspectRatio = PreserveAspectRatio + { _aspectRatioDefer :: !Bool + , _aspectRatioAlign :: !Alignment + , _aspectRatioMeetSlice :: !(Maybe MeetSlice) + } + deriving (Eq, Show) + +-- | Lenses for the PreserveAspectRatio type +makeClassy ''PreserveAspectRatio + +instance WithDefaultSvg PreserveAspectRatio where + defaultSvg = PreserveAspectRatio + { _aspectRatioDefer = False + , _aspectRatioAlign = AlignxMidYMid + , _aspectRatioMeetSlice = Nothing + } + +-- | Describe how the line should be terminated +-- when stroking them. Describe the values of the +-- `stroke-linecap` attribute. +-- See `_strokeLineCap` +data Cap + = CapRound -- ^ End with a round (`round` value) + | CapButt -- ^ Define straight just at the end (`butt` value) + | CapSquare -- ^ Straight further of the ends (`square` value) + deriving (Eq, Show) + +-- | Define the possible values of the `stroke-linejoin` +-- attribute. +-- see `_strokeLineJoin` +data LineJoin + = JoinMiter -- ^ `miter` value + | JoinBevel -- ^ `bevel` value + | JoinRound -- ^ `round` value + deriving (Eq, Show) + +-- | Describe the different value which can be used +-- in the `fill` or `stroke` attributes. +data Texture + = ColorRef PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb) + | TextureRef String -- ^ Link to a complex texture (url(#name)) + | FillNone -- ^ Equivalent to the `none` value. + deriving (Eq, Show) + +-- | Describe the possile filling algorithms. +-- Map the values of the `fill-rule` attributes. +data FillRule + = FillEvenOdd -- ^ Correspond to the `evenodd` value. + | FillNonZero -- ^ Correspond to the `nonzero` value. + deriving (Eq, Show) + +-- | Describe the content of the `transformation` attribute. +-- see `_transform` and `transform`. +data Transformation + = -- | Directly encode the translation matrix. + TransformMatrix !Coord !Coord !Coord + !Coord !Coord !Coord + -- | Translation along a vector + | Translate !Double !Double + -- | Scaling on both axis or on X axis and Y axis. + | Scale !Double !(Maybe Double) + -- | Rotation around `(0, 0)` or around an optional + -- point. + | Rotate !Double !(Maybe (Double, Double)) + -- | Skew transformation along the X axis. + | SkewX !Double + -- | Skew transformation along the Y axis. + | SkewY !Double + -- | Unkown transformation, like identity. + | TransformUnknown + deriving (Eq, Show) + +-- | Convert the Transformation to a string which can be +-- directly used in a svg attributes. +serializeTransformation :: Transformation -> String +serializeTransformation t = case t of + TransformUnknown -> "" + TransformMatrix a b c d e f -> + printf "matrix(%g, %g, %g, %g, %g, %g)" a b c d e f + Translate x y -> printf "translate(%g, %g)" x y + Scale x Nothing -> printf "scale(%g)" x + Scale x (Just y) -> printf "scale(%g, %g)" x y + Rotate angle Nothing -> printf "rotate(%g)" angle + Rotate angle (Just (x, y))-> printf "rotate(%g, %g, %g)" angle x y + SkewX x -> printf "skewX(%g)" x + SkewY y -> printf "skewY(%g)" y + +-- | Transform a list of transformations to a string for svg +-- `transform` attributes. +serializeTransformations :: [Transformation] -> String +serializeTransformations = + unwords . fmap serializeTransformation + +-- | Class helping find the drawing attributes for all +-- the SVG attributes. +class WithDrawAttributes a where + -- | Lens which can be used to read/write primitives. + drawAttr :: Lens' a DrawAttributes + +-- | Define an empty 'default' element for the SVG tree. +-- It is used as base when parsing the element from XML. +class WithDefaultSvg a where + -- | The default element. + defaultSvg :: a + +-- | Classify the font style, used to search a matching +-- font in the FontCache. +data FontStyle + = FontStyleNormal + | FontStyleItalic + | FontStyleOblique + deriving (Eq, Show) + +-- | Tell where to anchor the text, where the position +-- given is realative to the text. +data TextAnchor + -- | The text with left aligned, or start at the postion + -- If the point is the '*' then the text will be printed + -- this way: + -- + -- > *THE_TEXT_TO_PRINT + -- + -- Equivalent to the `start` value. + = TextAnchorStart + -- | The text is middle aligned, so the text will be at + -- the left and right of the position: + -- + -- > THE_TEXT*TO_PRINT + -- + -- Equivalent to the `middle` value. + | TextAnchorMiddle + -- | The text is right aligned. + -- + -- > THE_TEXT_TO_PRINT* + -- + -- Equivalent to the `end` value. + | TextAnchorEnd + deriving (Eq, Show) + + +-- | Correspond to the possible values of the +-- the attributes which are either `none` or +-- `url(#elem)` +data ElementRef + = RefNone -- ^ Value for `none` + | Ref String -- ^ Equivalent to `url()` attribute. + deriving (Eq, Show) + +-- | This type define how to draw any primitives, +-- which color to use, how to stroke the primitives +-- and the potential transformations to use. +-- +-- All these attributes are propagated to the children. +data DrawAttributes = DrawAttributes + { -- | Attribute corresponding to the `stroke-width` + -- SVG attribute. + _strokeWidth :: !(Last Number) + -- | Correspond to the `stroke` attribute. + , _strokeColor :: !(Last Texture) + -- | Define the `stroke-opacity` attribute, the transparency + -- for the "border". + , _strokeOpacity :: !(Maybe Float) + -- | Correspond to the `stroke-linecap` SVG + -- attribute + , _strokeLineCap :: !(Last Cap) + -- | Correspond to the `stroke-linejoin` SVG + -- attribute + , _strokeLineJoin :: !(Last LineJoin) + -- | Define the distance of the miter join, correspond + -- to the `stroke-miterlimit` attritbue. + , _strokeMiterLimit :: !(Last Double) + -- | Define the filling color of the elements. Corresponding + -- to the `fill` attribute. + , _fillColor :: !(Last Texture) + -- | Define the `fill-opacity` attribute, the transparency + -- for the "content". + , _fillOpacity :: !(Maybe Float) + -- | Define the global or group opacity attribute. + , _groupOpacity :: !(Maybe Float) + -- | Content of the `transform` attribute + , _transform :: !(Maybe [Transformation]) + -- | Define the `fill-rule` used during the rendering. + , _fillRule :: !(Last FillRule) + -- | Define the `mask` attribute. + , _maskRef :: !(Last ElementRef) + -- | Define the `clip-path` attribute. + , _clipPathRef :: !(Last ElementRef) + -- | Define the `clip-rule` attribute. + , _clipRule :: !(Last FillRule) + -- | Map to the `class` attribute. Used for the CSS + -- rewriting. + , _attrClass :: ![T.Text] + -- | Map to the `id` attribute. Used for the CSS + -- rewriting. + , _attrId :: !(Maybe String) + -- | Define the start distance of the dashing pattern. + -- Correspond to the `stroke-dashoffset` attribute. + , _strokeOffset :: !(Last Number) + -- | Define the dashing pattern for the lines. Correspond + -- to the `stroke-dasharray` attribute. + , _strokeDashArray :: !(Last [Number]) + -- | Current size of the text, correspond to the + -- `font-size` SVG attribute. + , _fontSize :: !(Last Number) + -- | Define the possible fonts to be used for text rendering. + -- Map to the `font-family` attribute. + , _fontFamily :: !(Last [String]) + -- | Map to the `font-style` attribute. + , _fontStyle :: !(Last FontStyle) + -- | Define how to interpret the text position, correspond + -- to the `text-anchor` attribute. + , _textAnchor :: !(Last TextAnchor) + -- | Define the marker used for the start of the line. + -- Correspond to the `marker-start` attribute. + , _markerStart :: !(Last ElementRef) + -- | Define the marker used for every point of the + -- polyline/path Correspond to the `marker-mid` + -- attribute. + , _markerMid :: !(Last ElementRef) + -- | Define the marker used for the end of the line. + -- Correspond to the `marker-end` attribute. + , _markerEnd :: !(Last ElementRef) + } + deriving (Eq, Show) + +-- | Lenses for the DrawAttributes type. +makeClassy ''DrawAttributes + +-- | This primitive describe an unclosed suite of +-- segments. Correspond to the `` tag. +data PolyLine = PolyLine + { -- | drawing attributes of the polyline. + _polyLineDrawAttributes :: !DrawAttributes + + -- | Geometry definition of the polyline. + -- correspond to the `points` attribute + , _polyLinePoints :: ![RPoint] + } + deriving (Eq, Show) + +-- | Lenses for the PolyLine type. +makeClassy ''PolyLine + +instance WithDefaultSvg PolyLine where + defaultSvg = PolyLine + { _polyLineDrawAttributes = mempty + , _polyLinePoints = [] + } + + +instance WithDrawAttributes PolyLine where + drawAttr = polyLineDrawAttributes + +-- | Primitive decriving polygon composed +-- of segements. Correspond to the `` +-- tag +data Polygon = Polygon + { -- | Drawing attributes for the polygon. + _polygonDrawAttributes :: !DrawAttributes + -- | Points of the polygon. Correspond to + -- the `points` attributes. + , _polygonPoints :: ![RPoint] + } + deriving (Eq, Show) + +-- | Lenses for the Polygon type +makeClassy ''Polygon + +instance WithDrawAttributes Polygon where + drawAttr = polygonDrawAttributes + +instance WithDefaultSvg Polygon where + defaultSvg = Polygon + { _polygonDrawAttributes = mempty + , _polygonPoints = [] + } + +-- | Define a simple line. Correspond to the +-- `` tag. +data Line = Line + { -- | Drawing attributes of line. + _lineDrawAttributes :: !DrawAttributes + -- | First point of the the line, correspond + -- to the `x1` and `y1` attributes. + , _linePoint1 :: !Point + -- | Second point of the the line, correspond + -- to the `x2` and `y2` attributes. + , _linePoint2 :: !Point + } + deriving (Eq, Show) + +-- | Lenses for the Line type. +makeClassy ''Line + +instance WithDrawAttributes Line where + drawAttr = lineDrawAttributes + +instance WithDefaultSvg Line where + defaultSvg = Line + { _lineDrawAttributes = mempty + , _linePoint1 = zeroPoint + , _linePoint2 = zeroPoint + } + where zeroPoint = (Num 0, Num 0) + +-- | Define a rectangle. Correspond to +-- `` svg tag. +data Rectangle = Rectangle + { -- | Rectangle drawing attributes. + _rectDrawAttributes :: !DrawAttributes + -- | Upper left corner of the rectangle, correspond + -- to the attributes `x` and `y`. + , _rectUpperLeftCorner :: !Point + -- | Rectangle width, correspond, strangely, to + -- the `width` attribute. + , _rectWidth :: !Number + -- | Rectangle height, correspond, amazingly, to + -- the `height` attribute. + , _rectHeight :: !Number + -- | Define the rounded corner radius radius + -- of the rectangle. Correspond to the `rx` and + -- `ry` attributes. + , _rectCornerRadius :: !(Number, Number) + } + deriving (Eq, Show) + +-- | Lenses for the Rectangle type. +makeClassy ''Rectangle + +instance WithDrawAttributes Rectangle where + drawAttr = rectDrawAttributes + +instance WithDefaultSvg Rectangle where + defaultSvg = Rectangle + { _rectDrawAttributes = mempty + , _rectUpperLeftCorner = (Num 0, Num 0) + , _rectWidth = Num 0 + , _rectHeight = Num 0 + , _rectCornerRadius = (Num 0, Num 0) + } + +-- | Type mapping the `` svg tag. +data Path = Path + { -- | Drawing attributes of the path. + _pathDrawAttributes :: !DrawAttributes + -- | Definition of the path, correspond to the + -- `d` attributes. + , _pathDefinition :: ![PathCommand] + } + deriving (Eq, Show) + +-- | Lenses for the Path type +makeClassy ''Path + +instance WithDrawAttributes Path where + drawAttr = pathDrawAttributes + +instance WithDefaultSvg Path where + defaultSvg = Path + { _pathDrawAttributes = mempty + , _pathDefinition = [] + } + +-- | Define a SVG group, corresponding `` tag. +data Group a = Group + { -- | Group drawing attributes, propagated to all of its + -- children. + _groupDrawAttributes :: !DrawAttributes + -- | Content of the group, corresponding to all the tags + -- inside the `` tag. + , _groupChildren :: ![a] + -- | Mapped to the attribute `viewBox` + , _groupViewBox :: !(Maybe (Double, Double, Double, Double)) + -- | used for symbols only + , _groupAspectRatio :: !PreserveAspectRatio + } + deriving (Eq, Show) + +-- | Lenses associated to the Group type. +makeClassy ''Group + +instance WithDrawAttributes (Group a) where + drawAttr = groupDrawAttributes + +instance WithDefaultSvg (Group a) where + defaultSvg = Group + { _groupDrawAttributes = mempty + , _groupChildren = [] + , _groupViewBox = Nothing + , _groupAspectRatio = defaultSvg + } + +-- | Define the `` tag, equivalent to +-- a named group. +newtype Symbol a = + Symbol { _groupOfSymbol :: Group a } + deriving (Eq, Show) + +-- | Lenses associated with the Symbol type. +makeLenses ''Symbol + +instance WithDrawAttributes (Symbol a) where + drawAttr = groupOfSymbol . drawAttr + +instance WithDefaultSvg (Symbol a) where + defaultSvg = Symbol defaultSvg + +-- | Define a ``. +data Circle = Circle + { -- | Drawing attributes of the circle. + _circleDrawAttributes :: !DrawAttributes + -- | Define the center of the circle, describe + -- the `cx` and `cy` attributes. + , _circleCenter :: !Point + -- | Radius of the circle, equivalent to the `r` + -- attribute. + , _circleRadius :: !Number + } + deriving (Eq, Show) + +-- | Lenses for the Circle type. +makeClassy ''Circle + +instance WithDrawAttributes Circle where + drawAttr = circleDrawAttributes + +instance WithDefaultSvg Circle where + defaultSvg = Circle + { _circleDrawAttributes = mempty + , _circleCenter = (Num 0, Num 0) + , _circleRadius = Num 0 + } + +-- | Define an `` +data Ellipse = Ellipse + { -- | Drawing attributes of the ellipse. + _ellipseDrawAttributes :: !DrawAttributes + -- | Center of the ellipse, map to the `cx` + -- and `cy` attributes. + , _ellipseCenter :: !Point + -- | Radius along the X axis, map the + -- `rx` attribute. + , _ellipseXRadius :: !Number + -- | Radius along the Y axis, map the + -- `ry` attribute. + , _ellipseYRadius :: !Number + } + deriving (Eq, Show) + +-- | Lenses for the ellipse type. +makeClassy ''Ellipse + +instance WithDrawAttributes Ellipse where + drawAttr = ellipseDrawAttributes + +instance WithDefaultSvg Ellipse where + defaultSvg = Ellipse + { _ellipseDrawAttributes = mempty + , _ellipseCenter = (Num 0, Num 0) + , _ellipseXRadius = Num 0 + , _ellipseYRadius = Num 0 + } + +-- | Define an `` tag. +data Image = Image + { -- | Drawing attributes of the image + _imageDrawAttributes :: !DrawAttributes + -- | Position of the image referenced by its + -- upper left corner. + , _imageCornerUpperLeft :: !Point + -- | Image width + , _imageWidth :: !Number + -- | Image Height + , _imageHeight :: !Number + -- | Image href, pointing to the real image. + , _imageHref :: !String + -- | preserveAspectRatio attribute + , _imageAspectRatio :: !PreserveAspectRatio + } + deriving (Eq, Show) + +-- | Lenses for the Image type. +makeClassy ''Image + +instance WithDrawAttributes Image where + drawAttr = imageDrawAttributes + +instance WithDefaultSvg Image where + defaultSvg = Image + { _imageDrawAttributes = mempty + , _imageCornerUpperLeft = (Num 0, Num 0) + , _imageWidth = Num 0 + , _imageHeight = Num 0 + , _imageHref = "" + , _imageAspectRatio = defaultSvg + } + +-- | Define an `` for a named content. +-- Every named content can be reused in the +-- document using this element. +data Use = Use + { -- | Position where to draw the "used" element. + -- Correspond to the `x` and `y` attributes. + _useBase :: Point + -- | Referenced name, correspond to `xlink:href` + -- attribute. + , _useName :: String + -- | Define the width of the region where + -- to place the element. Map to the `width` + -- attribute. + , _useWidth :: Maybe Number + -- | Define the height of the region where + -- to place the element. Map to the `height` + -- attribute. + , _useHeight :: Maybe Number + -- | Use draw attributes. + , _useDrawAttributes :: DrawAttributes + } + deriving (Eq, Show) + +-- | Lenses for the Use type. +makeClassy ''Use + +instance WithDrawAttributes Use where + drawAttr = useDrawAttributes + +instance WithDefaultSvg Use where + defaultSvg = Use + { _useBase = (Num 0, Num 0) + , _useName = "" + , _useWidth = Nothing + , _useHeight = Nothing + , _useDrawAttributes = mempty + } + +-- | Define position information associated to +-- `` or `` svg tag. +data TextInfo = TextInfo + { _textInfoX :: ![Number] -- ^ `x` attribute. + , _textInfoY :: ![Number] -- ^ `y` attribute. + , _textInfoDX :: ![Number] -- ^ `dx` attribute. + , _textInfoDY :: ![Number] -- ^ `dy` attribute. + , _textInfoRotate :: ![Double] -- ^ `rotate` attribute. + , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute. + } + deriving (Eq, Show) + +instance Monoid TextInfo where + mempty = TextInfo [] [] [] [] [] Nothing + mappend (TextInfo x1 y1 dx1 dy1 r1 l1) + (TextInfo x2 y2 dx2 dy2 r2 l2) = + TextInfo (x1 <> x2) (y1 <> y2) + (dx1 <> dx2) (dy1 <> dy2) + (r1 <> r2) + (getLast $ Last l1 <> Last l2) + +-- | Lenses for the TextInfo type. +makeClassy ''TextInfo + +instance WithDefaultSvg TextInfo where + defaultSvg = mempty + +-- | Define the content of a `` tag. +data TextSpanContent + = SpanText !T.Text -- ^ Raw text + | SpanTextRef !String -- ^ Equivalent to a `` + | SpanSub !TextSpan -- ^ Define a `` + deriving (Eq, Show) + +-- | Define a `` tag. +data TextSpan = TextSpan + { -- | Placing information for the text. + _spanInfo :: !TextInfo + -- | Drawing attributes for the text span. + , _spanDrawAttributes :: !DrawAttributes + -- | Content of the span. + , _spanContent :: ![TextSpanContent] + } + deriving (Eq, Show) + +-- | Lenses for the TextSpan type. +makeClassy ''TextSpan + +instance WithDefaultSvg TextSpan where + defaultSvg = TextSpan + { _spanInfo = defaultSvg + , _spanDrawAttributes = mempty + , _spanContent = mempty + } + +-- | Describe the content of the `method` attribute on +-- text path. +data TextPathMethod + = TextPathAlign -- ^ Map to the `align` value. + | TextPathStretch -- ^ Map to the `stretch` value. + deriving (Eq, Show) + +-- | Describe the content of the `spacing` text path +-- attribute. +data TextPathSpacing + = TextPathSpacingExact -- ^ Map to the `exact` value. + | TextPathSpacingAuto -- ^ Map to the `auto` value. + deriving (Eq, Show) + +-- | Describe the `` SVG tag. +data TextPath = TextPath + { -- | Define the beginning offset on the path, + -- the `startOffset` attribute. + _textPathStartOffset :: !Number + -- | Define the `xlink:href` attribute. + , _textPathName :: !String + -- | Correspond to the `method` attribute. + , _textPathMethod :: !TextPathMethod + -- | Correspond to the `spacing` attribute. + , _textPathSpacing :: !TextPathSpacing + -- | Real content of the path. + , _textPathData :: ![PathCommand] + } + deriving (Eq, Show) + +-- | Lenses for the TextPath type. +makeClassy ''TextPath + +instance WithDefaultSvg TextPath where + defaultSvg = TextPath + { _textPathStartOffset = Num 0 + , _textPathName = mempty + , _textPathMethod = TextPathAlign + , _textPathSpacing = TextPathSpacingExact + , _textPathData = [] + } + +-- | Define the possible values of the `lengthAdjust` +-- attribute. +data TextAdjust + = TextAdjustSpacing -- ^ Value `spacing` + | TextAdjustSpacingAndGlyphs -- ^ Value `spacingAndGlyphs` + deriving (Eq, Show) + +-- | Define the global `` SVG tag. +data Text = Text + { -- | Define the `lengthAdjust` attribute. + _textAdjust :: !TextAdjust + -- | Root of the text content. + , _textRoot :: !TextSpan + } + deriving (Eq, Show) + +-- | Lenses for the Text type. +makeClassy ''Text + +-- | Little helper to create a SVG text at a given +-- baseline position. +textAt :: Point -> T.Text -> Text +textAt (x, y) txt = Text TextAdjustSpacing tspan where + tspan = defaultSvg + { _spanContent = [SpanText txt] + , _spanInfo = defaultSvg + { _textInfoX = [x] + , _textInfoY = [y] + } + } + +instance WithDrawAttributes Text where + drawAttr = textRoot . spanDrawAttributes + +instance WithDefaultSvg Text where + defaultSvg = Text + { _textRoot = defaultSvg + , _textAdjust = TextAdjustSpacing + } + +-- | Main type for the scene description, reorient to +-- specific type describing each tag. +data Tree + = None + | UseTree { useInformation :: !Use + , useSubTree :: !(Maybe Tree) } + | GroupTree !(Group Tree) + | SymbolTree !(Symbol Tree) + | PathTree !Path + | CircleTree !Circle + | PolyLineTree !PolyLine + | PolygonTree !Polygon + | EllipseTree !Ellipse + | LineTree !Line + | RectangleTree !Rectangle + | TextTree !(Maybe TextPath) !Text + | ImageTree !Image + deriving (Eq, Show) + +-- | Define the orientation, associated to the +-- `orient` attribute on the Marker +data MarkerOrientation + = OrientationAuto -- ^ Auto value + | OrientationAngle Coord -- ^ Specific angle. + deriving (Eq, Show) + +-- | Define the content of the `markerUnits` attribute +-- on the Marker. +data MarkerUnit + = MarkerUnitStrokeWidth -- ^ Value `strokeWidth` + | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse` + deriving (Eq, Show) + +-- | Define the content of the `markerUnits` attribute +-- on the Marker. +data Overflow + = OverflowVisible -- ^ Value `visible` + | OverflowHidden -- ^ Value `hidden` + deriving (Eq, Show) + +-- | Define the `` tag. +data Marker = Marker + { -- | Draw attributes of the marker. + _markerDrawAttributes :: DrawAttributes + -- | Define the reference point of the marker. + -- correspond to the `refX` and `refY` attributes. + , _markerRefPoint :: !(Number, Number) + -- | Define the width of the marker. Correspond to + -- the `markerWidth` attribute. + , _markerWidth :: !(Maybe Number) + -- | Define the height of the marker. Correspond to + -- the `markerHeight` attribute. + , _markerHeight :: !(Maybe Number) + -- | Correspond to the `orient` attribute. + , _markerOrient :: !(Maybe MarkerOrientation) + -- | Map the `markerUnits` attribute. + , _markerUnits :: !(Maybe MarkerUnit) + -- | Optional viewbox + , _markerViewBox :: !(Maybe (Double, Double, Double, Double)) + -- | Elements defining the marker. + , _markerOverflow :: !(Maybe Overflow) + -- | preserveAspectRatio attribute + , _markerAspectRatio :: !PreserveAspectRatio + -- | Elements defining the marker. + , _markerElements :: [Tree] + } + deriving (Eq, Show) + +-- | Lenses for the Marker type. +makeClassy ''Marker + +instance WithDrawAttributes Marker where + drawAttr = markerDrawAttributes + +instance WithDefaultSvg Marker where + defaultSvg = Marker + { _markerDrawAttributes = mempty + , _markerRefPoint = (Num 0, Num 0) + , _markerWidth = Just (Num 3) + , _markerHeight = Just (Num 3) + , _markerOrient = Nothing -- MarkerOrientation + , _markerUnits = Nothing -- MarkerUnitStrokeWidth + , _markerViewBox = Nothing + , _markerOverflow = Nothing + , _markerElements = mempty + , _markerAspectRatio = defaultSvg + } + +-- | Insert element in the first sublist in the list of list. +appNode :: [[a]] -> a -> [[a]] +appNode [] e = [[e]] +appNode (curr:above) e = (e:curr) : above + +-- | Map a tree while propagating context information. +-- The function passed in parameter receive a list +-- representing the the path used to go arrive to the +-- current node. +zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree +zipTree f = dig [] where + dig prev e@None = f $ appNode prev e + dig prev e@(UseTree _ Nothing) = f $ appNode prev e + dig prev e@(UseTree nfo (Just u)) = + f . appNode prev . UseTree nfo . Just $ dig ([] : appNode prev e) u + dig prev e@(GroupTree g) = + f . appNode prev . GroupTree $ zipGroup (appNode prev e) g + dig prev e@(SymbolTree g) = + f . appNode prev . SymbolTree . Symbol . + zipGroup (appNode prev e) $ _groupOfSymbol g + dig prev e@(PathTree _) = f $ appNode prev e + dig prev e@(CircleTree _) = f $ appNode prev e + dig prev e@(PolyLineTree _) = f $ appNode prev e + dig prev e@(PolygonTree _) = f $ appNode prev e + dig prev e@(EllipseTree _) = f $ appNode prev e + dig prev e@(LineTree _) = f $ appNode prev e + dig prev e@(RectangleTree _) = f $ appNode prev e + dig prev e@(TextTree _ _) = f $ appNode prev e + dig prev e@(ImageTree _) = f $ appNode prev e + + zipGroup prev g = g { _groupChildren = updatedChildren } + where + groupChild = _groupChildren g + updatedChildren = + [dig (c:prev) child + | (child, c) <- zip groupChild $ inits groupChild] + +-- | Fold all nodes of a SVG tree. +foldTree :: (a -> Tree -> a) -> a -> Tree -> a +foldTree f = go where + go acc e = case e of + None -> f acc e + UseTree _ _ -> f acc e + PathTree _ -> f acc e + CircleTree _ -> f acc e + PolyLineTree _ -> f acc e + PolygonTree _ -> f acc e + EllipseTree _ -> f acc e + LineTree _ -> f acc e + RectangleTree _ -> f acc e + TextTree _ _ -> f acc e + ImageTree _ -> f acc e + GroupTree g -> + let subAcc = F.foldl' go acc $ _groupChildren g in + f subAcc e + SymbolTree s -> + let subAcc = + F.foldl' go acc . _groupChildren $ _groupOfSymbol s in + f subAcc e + +-- | Helper function mapping every tree element. +mapTree :: (Tree -> Tree) -> Tree -> Tree +mapTree f = go where + go e@None = f e + go e@(UseTree _ _) = f e + go (GroupTree g) = f . GroupTree $ mapGroup g + go (SymbolTree g) = + f . SymbolTree . Symbol . mapGroup $ _groupOfSymbol g + go e@(PathTree _) = f e + go e@(CircleTree _) = f e + go e@(PolyLineTree _) = f e + go e@(PolygonTree _) = f e + go e@(EllipseTree _) = f e + go e@(LineTree _) = f e + go e@(RectangleTree _) = f e + go e@(TextTree _ _) = f e + go e@(ImageTree _) = f e + + mapGroup g = + g { _groupChildren = map go $ _groupChildren g } + +-- | For every element of a svg tree, associate +-- it's SVG tag name. +nameOfTree :: Tree -> T.Text +nameOfTree v = + case v of + None -> "" + UseTree _ _ -> "use" + GroupTree _ -> "g" + SymbolTree _ -> "symbol" + PathTree _ -> "path" + CircleTree _ -> "circle" + PolyLineTree _ -> "polyline" + PolygonTree _ -> "polygon" + EllipseTree _ -> "ellipse" + LineTree _ -> "line" + RectangleTree _ -> "rectangle" + TextTree _ _ -> "text" + ImageTree _ -> "image" + +drawAttrOfTree :: Tree -> DrawAttributes +drawAttrOfTree v = case v of + None -> mempty + UseTree e _ -> e ^. drawAttr + GroupTree e -> e ^. drawAttr + SymbolTree e -> e ^. drawAttr + PathTree e -> e ^. drawAttr + CircleTree e -> e ^. drawAttr + PolyLineTree e -> e ^. drawAttr + PolygonTree e -> e ^. drawAttr + EllipseTree e -> e ^. drawAttr + LineTree e -> e ^. drawAttr + RectangleTree e -> e ^. drawAttr + TextTree _ e -> e ^. drawAttr + ImageTree e -> e ^. drawAttr + +setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree +setDrawAttrOfTree v attr = case v of + None -> None + UseTree e m -> UseTree (e & drawAttr .~ attr) m + GroupTree e -> GroupTree $ e & drawAttr .~ attr + SymbolTree e -> SymbolTree $ e & drawAttr .~ attr + PathTree e -> PathTree $ e & drawAttr .~ attr + CircleTree e -> CircleTree $ e & drawAttr .~ attr + PolyLineTree e -> PolyLineTree $ e & drawAttr .~ attr + PolygonTree e -> PolygonTree $ e & drawAttr .~ attr + EllipseTree e -> EllipseTree $ e & drawAttr .~ attr + LineTree e -> LineTree $ e & drawAttr .~ attr + RectangleTree e -> RectangleTree $ e & drawAttr .~ attr + TextTree a e -> TextTree a $ e & drawAttr .~ attr + ImageTree e -> ImageTree $ e & drawAttr .~ attr + +instance WithDrawAttributes Tree where + drawAttr = lens drawAttrOfTree setDrawAttrOfTree + +instance WithDefaultSvg Tree where + defaultSvg = None + +-- | Define the possible values of various *units attributes +-- used in the definition of the gradients and masks. +data CoordinateUnits + = CoordUserSpace -- ^ `userSpaceOnUse` value + | CoordBoundingBox -- ^ `objectBoundingBox` value + deriving (Eq, Show) + +-- | Define the possible values for the `spreadMethod` +-- values used for the gradient definitions. +data Spread + = SpreadRepeat -- ^ `reapeat` value + | SpreadPad -- ^ `pad` value + | SpreadReflect -- ^ `reflect value` + deriving (Eq, Show) + +-- | Define a color stop for the gradients. Represent +-- the `` SVG tag. +data GradientStop = GradientStop + { -- | Gradient offset between 0 and 1, correspond + -- to the `offset` attribute. + _gradientOffset :: Float + -- | Color of the gradient stop. Correspond + -- to the `stop-color` attribute. + , _gradientColor :: PixelRGBA8 + } + deriving (Eq, Show) + +-- | Lenses for the GradientStop type. +makeClassy ''GradientStop + +instance WithDefaultSvg GradientStop where + defaultSvg = GradientStop + { _gradientOffset = 0.0 + , _gradientColor = PixelRGBA8 0 0 0 255 + } + +-- | Define a `` tag. +data LinearGradient = LinearGradient + { -- | Define coordinate system of the gradient, + -- associated to the `gradientUnits` attribute. + _linearGradientUnits :: CoordinateUnits + -- | Point defining the beginning of the line gradient. + -- Associated to the `x1` and `y1` attribute. + , _linearGradientStart :: Point + -- | Point defining the end of the line gradient. + -- Associated to the `x2` and `y2` attribute. + , _linearGradientStop :: Point + -- | Define how to handle the values outside + -- the gradient start and stop. Associated to the + -- `spreadMethod` attribute. + , _linearGradientSpread :: Spread + -- | Define the transformation to apply to the + -- gradient points. Associated to the `gradientTransform` + -- attribute. + , _linearGradientTransform :: [Transformation] + -- | List of color stops of the linear gradient. + , _linearGradientStops :: [GradientStop] + } + deriving (Eq, Show) + +-- | Lenses for the LinearGradient type. +makeClassy ''LinearGradient + +instance WithDefaultSvg LinearGradient where + defaultSvg = LinearGradient + { _linearGradientUnits = CoordBoundingBox + , _linearGradientStart = (Percent 0, Percent 0) + , _linearGradientStop = (Percent 1, Percent 0) + , _linearGradientSpread = SpreadPad + , _linearGradientTransform = [] + , _linearGradientStops = [] + } + +-- | Define a `` tag. +data RadialGradient = RadialGradient + { -- | Define coordinate system of the gradient, + -- associated to the `gradientUnits` attribute. + _radialGradientUnits :: CoordinateUnits + -- | Center of the radial gradient. Associated to + -- the `cx` and `cy` attributes. + , _radialGradientCenter :: Point + -- | Radius of the radial gradient. Associated to + -- the `r` attribute. + , _radialGradientRadius :: Number + -- | X coordinate of the focus point of the radial + -- gradient. Associated to the `fx` attribute. + , _radialGradientFocusX :: Maybe Number + -- | Y coordinate of the focus point of the radial + -- gradient. Associated to the `fy` attribute. + , _radialGradientFocusY :: Maybe Number + -- | Define how to handle the values outside + -- the gradient start and stop. Associated to the + -- `spreadMethod` attribute. + , _radialGradientSpread :: Spread + -- | Define the transformation to apply to the + -- gradient points. Associated to the `gradientTransform` + -- attribute. + , _radialGradientTransform :: [Transformation] + -- | List of color stops of the radial gradient. + , _radialGradientStops :: [GradientStop] + } + deriving (Eq, Show) + +-- | Lenses for the RadialGradient type. +makeClassy ''RadialGradient + +instance WithDefaultSvg RadialGradient where + defaultSvg = RadialGradient + { _radialGradientUnits = CoordBoundingBox + , _radialGradientCenter = (Percent 0.5, Percent 0.5) + , _radialGradientRadius = Percent 0.5 + , _radialGradientFocusX = Nothing + , _radialGradientFocusY = Nothing + , _radialGradientSpread = SpreadPad + , _radialGradientTransform = [] + , _radialGradientStops = [] + } + +-- | Define a SVG `` tag. +data Mask = Mask + { -- | Drawing attributes of the Mask + _maskDrawAttributes :: DrawAttributes + -- | Correspond to the `maskContentUnits` attributes. + , _maskContentUnits :: CoordinateUnits + -- | Mapping to the `maskUnits` attribute. + , _maskUnits :: CoordinateUnits + -- | Map to the `x` and `y` attributes. + , _maskPosition :: Point + -- | Map to the `width` attribute + , _maskWidth :: Number + -- | Map to the `height` attribute. + , _maskHeight :: Number + -- | Children of the `` tag. + , _maskContent :: [Tree] + } + deriving (Eq, Show) + +-- | Lenses for the Mask type. +makeClassy ''Mask + +instance WithDrawAttributes Mask where + drawAttr = maskDrawAttributes + +instance WithDefaultSvg Mask where + defaultSvg = Mask + { _maskDrawAttributes = mempty + , _maskContentUnits = CoordUserSpace + , _maskUnits = CoordBoundingBox + , _maskPosition = (Percent (-0.1), Percent (-0.1)) + , _maskWidth = Percent 1.2 + , _maskHeight = Percent 1.2 + , _maskContent = [] + } + +-- | Define a `` tag. +data ClipPath = ClipPath + { _clipPathDrawAttributes :: DrawAttributes + -- | Maps to the `clipPathUnits` attribute + , _clipPathUnits :: CoordinateUnits + -- | Maps to the content of the tree + , _clipPathContent :: [Tree] + } + deriving (Eq, Show) + +-- | Lenses for the ClipPath type. +makeClassy ''ClipPath + +instance WithDrawAttributes ClipPath where + drawAttr = clipPathDrawAttributes + +instance WithDefaultSvg ClipPath where + defaultSvg = ClipPath + { _clipPathDrawAttributes = mempty + , _clipPathUnits = CoordUserSpace + , _clipPathContent = mempty + } + +-- | Define a `` tag. +data Pattern = Pattern + { -- | Pattern drawing attributes. + _patternDrawAttributes :: !DrawAttributes + -- | Possible `viewBox`. + , _patternViewBox :: !(Maybe (Double, Double, Double, Double)) + -- | Width of the pattern tile, mapped to the + -- `width` attribute + , _patternWidth :: !Number + -- | Height of the pattern tile, mapped to the + -- `height` attribute + , _patternHeight :: !Number + -- | Pattern tile base, mapped to the `x` and + -- `y` attributes. + , _patternPos :: !Point + -- | Elements used in the pattern. + , _patternElements :: ![Tree] + -- | Define the cordinate system to use for + -- the pattern. Mapped to the `patternUnits` + -- attribute. + , _patternUnit :: !CoordinateUnits + -- | Value of the "preserveAspectRatio" attribute + , _patternAspectRatio :: !PreserveAspectRatio + } + deriving Show + +-- | Lenses for the Patter type. +makeClassy ''Pattern + +instance WithDrawAttributes Pattern where + drawAttr = patternDrawAttributes + +instance WithDefaultSvg Pattern where + defaultSvg = Pattern + { _patternViewBox = Nothing + , _patternWidth = Num 0 + , _patternHeight = Num 0 + , _patternPos = (Num 0, Num 0) + , _patternElements = [] + , _patternUnit = CoordBoundingBox + , _patternDrawAttributes = mempty + , _patternAspectRatio = defaultSvg + } + +-- | Sum types helping keeping track of all the namable +-- elemens in a SVG document. +data Element + = ElementLinearGradient LinearGradient + | ElementRadialGradient RadialGradient + | ElementGeometry Tree + | ElementPattern Pattern + | ElementMarker Marker + | ElementMask Mask + | ElementClipPath ClipPath + deriving Show + +-- | Represent a full svg document with style, +-- geometry and named elements. +data Document = Document + { _viewBox :: Maybe (Double, Double, Double, Double) + , _width :: Maybe Number + , _height :: Maybe Number + , _elements :: [Tree] + , _definitions :: M.Map String Element + , _description :: String + , _styleRules :: [CssRule] + , _documentLocation :: FilePath + } + deriving Show + +-- | Lenses associated to a SVG document. +makeClassy ''Document + +-- | Calculate the document size in function of the +-- different available attributes in the document. +documentSize :: Dpi -> Document -> (Int, Int) +documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) + , _width = Just (Percent pw) + , _height = Just (Percent ph) + } = + (floor $ dx * pw, floor $ dy * ph) + where + dx = abs $ x2 - x1 + dy = abs $ y2 - y1 +documentSize _ Document { _width = Just (Num w) + , _height = Just (Num h) } = (floor w, floor h) +documentSize dpi doc@(Document { _width = Just w + , _height = Just h }) = + documentSize dpi $ doc + { _width = Just $ toUserUnit dpi w + , _height = Just $ toUserUnit dpi h } +documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } = + (floor . abs $ x2 - x1, floor . abs $ y2 - y1) +documentSize _ _ = (1, 1) + +mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a +mayMerge (Just a) (Just b) = Just $ mappend a b +mayMerge _ b@(Just _) = b +mayMerge a Nothing = a + +instance Monoid DrawAttributes where + mempty = DrawAttributes + { _strokeWidth = Last Nothing + , _strokeColor = Last Nothing + , _strokeOpacity = Nothing + , _strokeLineCap = Last Nothing + , _strokeLineJoin = Last Nothing + , _strokeMiterLimit = Last Nothing + , _fillColor = Last Nothing + , _groupOpacity = Nothing + , _fillOpacity = Nothing + , _fontSize = Last Nothing + , _fontFamily = Last Nothing + , _fontStyle = Last Nothing + , _transform = Nothing + , _fillRule = Last Nothing + , _attrClass = mempty + , _attrId = Nothing + , _strokeOffset = Last Nothing + , _strokeDashArray = Last Nothing + , _textAnchor = Last Nothing + , _maskRef = Last Nothing + , _clipPathRef = Last Nothing + , _clipRule = Last Nothing + + , _markerStart = Last Nothing + , _markerMid = Last Nothing + , _markerEnd = Last Nothing + } + + mappend a b = DrawAttributes + { _strokeWidth = (mappend `on` _strokeWidth) a b + , _strokeColor = (mappend `on` _strokeColor) a b + , _strokeLineCap = (mappend `on` _strokeLineCap) a b + , _strokeOpacity = (opacityMappend `on` _strokeOpacity) a b + , _strokeLineJoin = (mappend `on` _strokeLineJoin) a b + , _strokeMiterLimit = (mappend `on` _strokeMiterLimit) a b + , _fillColor = (mappend `on` _fillColor) a b + , _fillOpacity = (opacityMappend `on` _fillOpacity) a b + , _fontSize = (mappend `on` _fontSize) a b + , _transform = (mayMerge `on` _transform) a b + , _fillRule = (mappend `on` _fillRule) a b + , _attrClass = _attrClass b + , _attrId = _attrId b + , _groupOpacity = _groupOpacity b + , _strokeOffset = (mappend `on` _strokeOffset) a b + , _strokeDashArray = (mappend `on` _strokeDashArray) a b + , _fontFamily = (mappend `on` _fontFamily) a b + , _fontStyle = (mappend `on` _fontStyle) a b + , _textAnchor = (mappend `on` _textAnchor) a b + , _maskRef = (mappend `on` _maskRef) a b + , _clipPathRef = (mappend `on` _clipPathRef) a b + , _clipRule = (mappend `on` _clipRule) a b + , _markerStart = (mappend `on` _markerStart) a b + , _markerMid = (mappend `on` _markerMid) a b + , _markerEnd = (mappend `on` _markerEnd) a b + } + where + opacityMappend Nothing Nothing = Nothing + opacityMappend (Just v) Nothing = Just v + opacityMappend Nothing (Just v) = Just v + opacityMappend (Just v) (Just v2) = Just $ v * v2 + +instance WithDefaultSvg DrawAttributes where + defaultSvg = mempty + +instance CssMatcheable Tree where + cssAttribOf _ _ = Nothing + cssClassOf = view (drawAttr . attrClass) + cssIdOf = fmap T.pack . view (drawAttr . attrId) + cssNameOf = nameOfTree + 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,1164 +1,1164 @@ -{-# 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,6,0) -import Text.Read( reads ) -#else -import Text.Read( readMaybe ) -#endif - -#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( fromMaybe, catMaybes ) -import Data.Monoid( Last( Last ), getLast, (<>) ) -import Data.List( foldl', intercalate ) -import Text.XML.Light.Proc( findAttrBy, elChildren, strContent ) -import qualified Text.XML.Light as X -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-} - -#if !MIN_VERSION_base(4,6,0) -readMaybe :: Read a => String -> Maybe a -readMaybe str = case reads str of - [] -> Nothing - (x, _):_ -> Just x -#endif - -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 Double 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 Alignment where - aparse s = Just $ case s of - "none" -> AlignNone - "xMinYMin" -> AlignxMinYMin - "xMidYMin" -> AlignxMidYMin - "xMaxYMin" -> AlignxMaxYMin - "xMinYMid" -> AlignxMinYMid - "xMidYMid" -> AlignxMidYMid - "xMaxYMid" -> AlignxMaxYMid - "xMinYMax" -> AlignxMinYMax - "xMidYMax" -> AlignxMidYMax - "xMaxYMax" -> AlignxMaxYMax - _ -> _aspectRatioAlign defaultSvg - - aserialize v = Just $ case v of - AlignNone -> "none" - AlignxMinYMin -> "xMinYMin" - AlignxMidYMin -> "xMidYMin" - AlignxMaxYMin -> "xMaxYMin" - AlignxMinYMid -> "xMinYMid" - AlignxMidYMid -> "xMidYMid" - AlignxMaxYMid -> "xMaxYMid" - AlignxMinYMax -> "xMinYMax" - AlignxMidYMax -> "xMidYMax" - AlignxMaxYMax -> "xMaxYMax" - -instance ParseableAttribute MeetSlice where - aparse s = case s of - "meet" -> Just Meet - "slice" -> Just Slice - _ -> Nothing - - aserialize v = Just $ case v of - Meet -> "meet" - Slice -> "slice" - -instance ParseableAttribute PreserveAspectRatio where - aserialize v = Just $ defer <> align <> meetSlice where - defer = if _aspectRatioDefer v then "defer " else "" - align = fromMaybe "" . aserialize $ _aspectRatioAlign v - meetSlice = fromMaybe "" $ aserialize =<< _aspectRatioMeetSlice v - - aparse s = case words s of - [] -> Nothing - [align] -> Just $ defaultSvg { _aspectRatioAlign = alignOf align } - ["defer", align] -> - Just $ defaultSvg - { _aspectRatioDefer = True - , _aspectRatioAlign = alignOf align - } - [align, meet] -> - Just $ defaultSvg - { _aspectRatioMeetSlice = aparse meet - , _aspectRatioAlign = alignOf align - } - ["defer", align, meet] -> - Just $ PreserveAspectRatio - { _aspectRatioDefer = True - , _aspectRatioAlign = alignOf align - , _aspectRatioMeetSlice = aparse meet - } - _ -> Nothing - where - alignOf = fromMaybe (_aspectRatioAlign defaultSvg) . aparse - -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 Overflow where - aparse s = case s of - "visible" -> Just OverflowVisible - "hidden" -> Just OverflowHidden - _ -> Nothing - - aserialize u = Just $ case u of - OverflowVisible -> "visible" - OverflowHidden -> "hidden" - -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 (Double, Double, Double, Double) 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 -> Maybe X.Element - -setChildren :: X.Element -> [X.Content] -> X.Element -setChildren xNode children = xNode { X.elContent = children } - -updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> Maybe X.Element -> Maybe X.Element -updateWithAccessor _ _ Nothing = Nothing -updateWithAccessor accessor node (Just xNode) = - Just . setChildren xNode . fmap X.Elem . catMaybes $ serializeTreeNode <$> accessor node - -genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> Maybe X.Element -genericSerializeNode node = - Just . 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 -> Maybe X.Element -genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where - thisXml = genericSerializeNode node - drawAttrNode = genericSerializeNode $ node ^. drawAttr - -type CssUpdater = - DrawAttributes -> [[CssElement]] -> DrawAttributes - -opacitySetter :: String -> Lens' a (Maybe Float) -> SvgAttributeLens a -opacitySetter attribute elLens = - SvgAttributeLens attribute updater serializer - where - serializer a = printf "%g" <$> a ^. elLens - updater el str = case parseMayStartDot num str of - Nothing -> el - Just v -> el & elLens .~ Just (realToFrac v) - -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 = case a ^. attrClass of - [] -> Nothing - lst -> Just . T.unpack $ T.intercalate " " lst - -cssUniqueNumber :: ASetter DrawAttributes DrawAttributes - a (Last Number) - -> CssUpdater -cssUniqueNumber setter attr ((CssNumber n:_):_) = - attr & setter .~ Last (Just n) -cssUniqueNumber _ attr _ = attr - -cssUniqueFloat :: (Fractional n) - => ASetter DrawAttributes DrawAttributes a (Maybe n) - -> CssUpdater -cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = - attr & setter .~ Just (realToFrac n) -cssUniqueFloat _ attr _ = attr - -cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Double) - -> 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) - ,(opacitySetter "opacity" groupOpacity, cssUniqueFloat groupOpacity) - ,(opacitySetter "fill-opacity" fillOpacity, cssUniqueFloat fillOpacity) - ,(opacitySetter "stroke-opacity" strokeOpacity, 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 - ,"preserveAspectRatio" `parseIn` imageAspectRatio - ] - -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 -> Nothing - 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 -> do - textNode <- serializeTreeNode t - pathNode <- serializeTreeNode p - let sub = [X.Elem . setChildren pathNode $ X.elContent textNode] - return $ setChildren textNode sub - - -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) - ,"preserveAspectRatio" `parseIn` (groupOfSymbol . groupAspectRatio) - ] - - -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) - ,"preserveAspectRatio" `parseIn` patternAspectRatio - ] - -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 - ,"overflow" `parseIn` markerOverflow - ,"preserveAspectRatio" `parseIn` markerAspectRatio - ] - -serializeText :: Text -> Maybe X.Element -serializeText topText = namedNode where - namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode - topNode = serializeSpan $ _textRoot topText - - serializeSpan tspan = case (info, drawInfo) of - (Nothing, Nothing) -> Nothing - (Just a, Nothing) -> Just $ setChildren a subContent - (Nothing, Just b) -> Just $ setChildren b subContent - (Just a, Just b) -> - Just $ setChildren (mergeAttributes a b) subContent - where - info = genericSerializeNode $ _spanInfo tspan - drawInfo = genericSerializeNode $ _spanDrawAttributes tspan - subContent = catMaybes $ serializeContent <$> _spanContent tspan - - serializeContent (SpanText t) = Just . X.Text $ X.blank_cdata { X.cdData = T.unpack t } - serializeContent (SpanTextRef _t) = Just . 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 = realToFrac $ 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 = catMaybes [serializeTreeNode el | el <- _elements doc] - - defsTag | null defs = [] - | otherwise = [X.node (X.unqual "defs") defs] - - defs = catMaybes [elementRender k e | (k, e) <- M.assocs $ _definitions doc] - - elementRender k e = case e of - ElementGeometry t -> serialize t - ElementMarker m -> serialize m - ElementMask m -> serialize m - ElementClipPath c -> serialize c - ElementPattern p -> serialize p - ElementLinearGradient lg -> addId $ serializeTreeNode lg - ElementRadialGradient rg -> addId $ serializeTreeNode rg - where - addId = fmap (X.add_attr $ attr "id" k) - - serialize :: (WithDrawAttributes e, XMLUpdatable e) => e -> Maybe X.Element - serialize el = case el^.drawAttr.attrId of - Nothing -> addId $ serializeTreeNode el - Just _id -> - let newNode = el & drawAttr.attrId .~ Just k in - serializeTreeNode newNode - - 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,6,0) +import Text.Read( reads ) +#else +import Text.Read( readMaybe ) +#endif + +#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( fromMaybe, catMaybes ) +import Data.Monoid( Last( Last ), getLast, (<>) ) +import Data.List( foldl', intercalate ) +import Text.XML.Light.Proc( findAttrBy, elChildren, strContent ) +import qualified Text.XML.Light as X +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-} + +#if !MIN_VERSION_base(4,6,0) +readMaybe :: Read a => String -> Maybe a +readMaybe str = case reads str of + [] -> Nothing + (x, _):_ -> Just x +#endif + +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 pathParser + aserialize = Just . serializeCommands + +instance ParseableAttribute [RPoint] where + aparse = parse pointData + aserialize = Just . serializePoints + +instance ParseableAttribute Double 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 Alignment where + aparse s = Just $ case s of + "none" -> AlignNone + "xMinYMin" -> AlignxMinYMin + "xMidYMin" -> AlignxMidYMin + "xMaxYMin" -> AlignxMaxYMin + "xMinYMid" -> AlignxMinYMid + "xMidYMid" -> AlignxMidYMid + "xMaxYMid" -> AlignxMaxYMid + "xMinYMax" -> AlignxMinYMax + "xMidYMax" -> AlignxMidYMax + "xMaxYMax" -> AlignxMaxYMax + _ -> _aspectRatioAlign defaultSvg + + aserialize v = Just $ case v of + AlignNone -> "none" + AlignxMinYMin -> "xMinYMin" + AlignxMidYMin -> "xMidYMin" + AlignxMaxYMin -> "xMaxYMin" + AlignxMinYMid -> "xMinYMid" + AlignxMidYMid -> "xMidYMid" + AlignxMaxYMid -> "xMaxYMid" + AlignxMinYMax -> "xMinYMax" + AlignxMidYMax -> "xMidYMax" + AlignxMaxYMax -> "xMaxYMax" + +instance ParseableAttribute MeetSlice where + aparse s = case s of + "meet" -> Just Meet + "slice" -> Just Slice + _ -> Nothing + + aserialize v = Just $ case v of + Meet -> "meet" + Slice -> "slice" + +instance ParseableAttribute PreserveAspectRatio where + aserialize v = Just $ defer <> align <> meetSlice where + defer = if _aspectRatioDefer v then "defer " else "" + align = fromMaybe "" . aserialize $ _aspectRatioAlign v + meetSlice = fromMaybe "" $ aserialize =<< _aspectRatioMeetSlice v + + aparse s = case words s of + [] -> Nothing + [align] -> Just $ defaultSvg { _aspectRatioAlign = alignOf align } + ["defer", align] -> + Just $ defaultSvg + { _aspectRatioDefer = True + , _aspectRatioAlign = alignOf align + } + [align, meet] -> + Just $ defaultSvg + { _aspectRatioMeetSlice = aparse meet + , _aspectRatioAlign = alignOf align + } + ["defer", align, meet] -> + Just $ PreserveAspectRatio + { _aspectRatioDefer = True + , _aspectRatioAlign = alignOf align + , _aspectRatioMeetSlice = aparse meet + } + _ -> Nothing + where + alignOf = fromMaybe (_aspectRatioAlign defaultSvg) . aparse + +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 Overflow where + aparse s = case s of + "visible" -> Just OverflowVisible + "hidden" -> Just OverflowHidden + _ -> Nothing + + aserialize u = Just $ case u of + OverflowVisible -> "visible" + OverflowHidden -> "hidden" + +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 (Double, Double, Double, Double) 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 -> Maybe X.Element + +setChildren :: X.Element -> [X.Content] -> X.Element +setChildren xNode children = xNode { X.elContent = children } + +updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> Maybe X.Element -> Maybe X.Element +updateWithAccessor _ _ Nothing = Nothing +updateWithAccessor accessor node (Just xNode) = + Just . setChildren xNode . fmap X.Elem . catMaybes $ serializeTreeNode <$> accessor node + +genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> Maybe X.Element +genericSerializeNode node = + Just . 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 -> Maybe X.Element +genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where + thisXml = genericSerializeNode node + drawAttrNode = genericSerializeNode $ node ^. drawAttr + +type CssUpdater = + DrawAttributes -> [[CssElement]] -> DrawAttributes + +opacitySetter :: String -> Lens' a (Maybe Float) -> SvgAttributeLens a +opacitySetter attribute elLens = + SvgAttributeLens attribute updater serializer + where + serializer a = printf "%g" <$> a ^. elLens + updater el str = case parseMayStartDot num str of + Nothing -> el + Just v -> el & elLens .~ Just (realToFrac v) + +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 = case a ^. attrClass of + [] -> Nothing + lst -> Just . T.unpack $ T.intercalate " " lst + +cssUniqueNumber :: ASetter DrawAttributes DrawAttributes + a (Last Number) + -> CssUpdater +cssUniqueNumber setter attr ((CssNumber n:_):_) = + attr & setter .~ Last (Just n) +cssUniqueNumber _ attr _ = attr + +cssUniqueFloat :: (Fractional n) + => ASetter DrawAttributes DrawAttributes a (Maybe n) + -> CssUpdater +cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = + attr & setter .~ Just (realToFrac n) +cssUniqueFloat _ attr _ = attr + +cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Double) + -> 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) + ,(opacitySetter "opacity" groupOpacity, cssUniqueFloat groupOpacity) + ,(opacitySetter "fill-opacity" fillOpacity, cssUniqueFloat fillOpacity) + ,(opacitySetter "stroke-opacity" strokeOpacity, 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 + ,"preserveAspectRatio" `parseIn` imageAspectRatio + ] + +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 -> Nothing + 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 -> do + textNode <- serializeTreeNode t + pathNode <- serializeTreeNode p + let sub = [X.Elem . setChildren pathNode $ X.elContent textNode] + return $ setChildren textNode sub + + +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) + ,"preserveAspectRatio" `parseIn` (groupOfSymbol . groupAspectRatio) + ] + + +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) + ,"preserveAspectRatio" `parseIn` patternAspectRatio + ] + +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 + ,"overflow" `parseIn` markerOverflow + ,"preserveAspectRatio" `parseIn` markerAspectRatio + ] + +serializeText :: Text -> Maybe X.Element +serializeText topText = namedNode where + namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode + topNode = serializeSpan $ _textRoot topText + + serializeSpan tspan = case (info, drawInfo) of + (Nothing, Nothing) -> Nothing + (Just a, Nothing) -> Just $ setChildren a subContent + (Nothing, Just b) -> Just $ setChildren b subContent + (Just a, Just b) -> + Just $ setChildren (mergeAttributes a b) subContent + where + info = genericSerializeNode $ _spanInfo tspan + drawInfo = genericSerializeNode $ _spanDrawAttributes tspan + subContent = catMaybes $ serializeContent <$> _spanContent tspan + + serializeContent (SpanText t) = Just . X.Text $ X.blank_cdata { X.cdData = T.unpack t } + serializeContent (SpanTextRef _t) = Just . 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 = realToFrac $ 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 = catMaybes [serializeTreeNode el | el <- _elements doc] + + defsTag | null defs = [] + | otherwise = [X.node (X.unqual "defs") defs] + + defs = catMaybes [elementRender k e | (k, e) <- M.assocs $ _definitions doc] + + elementRender k e = case e of + ElementGeometry t -> serialize t + ElementMarker m -> serialize m + ElementMask m -> serialize m + ElementClipPath c -> serialize c + ElementPattern p -> serialize p + ElementLinearGradient lg -> addId $ serializeTreeNode lg + ElementRadialGradient rg -> addId $ serializeTreeNode rg + where + addId = fmap (X.add_attr $ attr "id" k) + + serialize :: (WithDrawAttributes e, XMLUpdatable e) => e -> Maybe X.Element + serialize el = case el^.drawAttr.attrId of + Nothing -> addId $ serializeTreeNode el + Just _id -> + let newNode = el & drawAttr.attrId .~ Just k in + serializeTreeNode newNode + + 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,61 +1,61 @@ -name: svg-tree -version: 0.5.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.md - -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.5.1.1 - -library - hs-source-dirs: src - Ghc-options: -O3 -Wall - 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.5 && < 5 - , JuicyPixels >= 3.2 - , attoparsec >= 0.12 - , scientific >= 0.3 - , containers >= 0.4 - , xml >= 1.3 - , bytestring >= 0.10 - , linear >= 1.20 - , vector >= 0.10 - , text >= 1.1 - , transformers >= 0.3 && < 0.6 - , mtl >= 2.1 && < 2.3 - , lens >= 4.6 && < 5 - +name: svg-tree +version: 0.5.1.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.md + +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.5.1.2 + +library + hs-source-dirs: src + Ghc-options: -O3 -Wall + 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.5 && < 5 + , JuicyPixels >= 3.2 + , attoparsec >= 0.12 + , scientific >= 0.3 + , containers >= 0.4 + , xml >= 1.3 + , bytestring >= 0.10 + , linear >= 1.20 + , vector >= 0.10 + , text >= 1.1 + , transformers >= 0.3 && < 0.6 + , mtl >= 2.1 && < 2.3 + , lens >= 4.6 && < 5 +