svg-tree (empty) → 0.1
raw patch · 11 files changed
+3728/−0 lines, 11 filesdep +JuicyPixelsdep +attoparsecdep +basesetup-changed
Dependencies added: JuicyPixels, attoparsec, base, bytestring, containers, lens, linear, mtl, scientific, text, transformers, vector, xml
Files
- Setup.hs +2/−0
- changelog +5/−0
- src/Graphics/Svg.hs +107/−0
- src/Graphics/Svg/ColorParser.hs +111/−0
- src/Graphics/Svg/CssParser.hs +257/−0
- src/Graphics/Svg/CssTypes.hs +271/−0
- src/Graphics/Svg/NamedColors.hs +158/−0
- src/Graphics/Svg/PathParser.hs +226/−0
- src/Graphics/Svg/Types.hs +1452/−0
- src/Graphics/Svg/XmlParser.hs +1077/−0
- svg-tree.cabal +62/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ changelog view
@@ -0,0 +1,5 @@+-*-change-log-*- + +v0.1 + * Initial release +
+ src/Graphics/Svg.hs view
@@ -0,0 +1,107 @@+-- | Module providing basic input/output for the SVG document, +-- for document building, please refer to Graphics.Svg.Types. +module Graphics.Svg ( -- * Saving/Loading functions + loadSvgFile + , parseSvgFile + , xmlOfDocument + , saveXmlFile + + -- * Manipulation functions + , cssApply + , cssRulesOfText + , applyCSSRules + , resolveUses + + -- * Type definitions + , module Graphics.Svg.Types + ) where + +import Control.Applicative( (<$>) ) +import Data.List( foldl' ) +import qualified Data.ByteString as B +import qualified Data.Map as M +import qualified Data.Text as T +import Text.XML.Light.Input( parseXMLDoc ) +import Text.XML.Light.Output( ppcTopElement, prettyConfigPP ) +import Control.Lens + +import Graphics.Svg.Types +import Graphics.Svg.CssTypes +import Graphics.Svg.CssParser( cssRulesOfText ) +import Graphics.Svg.XmlParser + +{-import Graphics.Svg.CssParser-} + +-- | Try to load an svg file on disc and parse it as +-- a SVG Document. +loadSvgFile :: FilePath -> IO (Maybe Document) +loadSvgFile filename = + parseSvgFile filename <$> B.readFile filename + +-- | Parse an in-memory SVG file +parseSvgFile :: FilePath -- ^ Source path/URL of the document, used + -- to resolve relative links. + -> B.ByteString + -> Maybe Document +parseSvgFile filename fileContent = + parseXMLDoc fileContent >>= unparseDocument filename + +-- | Save a svg Document on a file on disk. +saveXmlFile :: FilePath -> Document -> IO () +saveXmlFile filePath = + writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument + +cssDeclApplyer :: DrawAttributes -> CssDeclaration + -> DrawAttributes +cssDeclApplyer value (CssDeclaration txt elems) = + case lookup txt cssUpdaters of + Nothing -> value + Just f -> f value elems + where + cssUpdaters = [(T.pack $ _attributeName n, u) | + (n, u) <- drawAttributesList] + +-- | Rewrite a SVG Tree using some CSS rules. +-- +-- This action will propagate the definition of the +-- css directly in each matched element. +cssApply :: [CssRule] -> Tree -> Tree +cssApply rules = zipTree go where + go [] = None + go ([]:_) = None + go context@((t:_):_) = t & drawAttr .~ attr' + where + matchingDeclarations = + findMatchingDeclarations rules context + attr = view drawAttr t + attr' = foldl' cssDeclApplyer attr matchingDeclarations + +-- | For every 'use' tag, try to resolve the geometry associated +-- with it and place it in the scene Tree. It is important to +-- resolve the 'use' tag before applying the CSS rules, as some +-- rules may apply some elements matching the children of "use". +resolveUses :: Document -> Document +resolveUses doc = + doc { _elements = mapTree fetchUses <$> _elements doc } + where + fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo + fetchUses a = a + + search nfo = maybe Nothing geometryExtract found where + found = M.lookup (_useName nfo) $ _definitions doc + + geometryExtract c = case c of + ElementLinearGradient _ -> Nothing + ElementRadialGradient _ -> Nothing + ElementMask _ -> Nothing + ElementClipPath _ -> Nothing + ElementGeometry t -> Just t + ElementPattern _ -> Nothing + ElementMarker _ -> Nothing + +-- | Rewrite the document by applying the CSS rules embedded +-- inside it. +applyCSSRules :: Document -> Document +applyCSSRules doc = doc + { _elements = cssApply (_styleRules doc) <$> _elements doc } +
+ src/Graphics/Svg/ColorParser.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.Svg.ColorParser( colorParser + , colorSerializer + , textureParser + , textureSerializer + , urlRef + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<*), (*>) ) +#endif + +import Data.Bits( (.|.), unsafeShiftL ) +import Control.Applicative( (<$>), (<$), (<|>) ) +import Data.Attoparsec.Text + ( Parser + , string + , skipSpace + , satisfy + , inClass + , takeWhile1 + , option + , char + , digit + , letter + , many1 + , scientific + ) + +import Text.Printf( printf ) +import Data.Scientific( toRealFloat ) +import Codec.Picture( PixelRGBA8( .. ) ) +import Data.Word( Word8 ) +import Graphics.Svg.NamedColors +import Graphics.Svg.Types +import qualified Data.Map as M + +commaWsp :: Parser () +commaWsp = skipSpace *> option () (string "," *> return ()) + <* skipSpace + + +num :: Parser Double +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber :: Parser Float + doubleNumber = toRealFloat <$> scientific + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + +colorSerializer :: PixelRGBA8 -> String +colorSerializer (PixelRGBA8 r g b _) = printf "#%02X%02X%02X" r g b + +colorParser :: Parser PixelRGBA8 +colorParser = rgbColor + <|> (string "#" *> (color <|> colorReduced)) + <|> namedColor + where + charRange c1 c2 = + (\c -> fromIntegral $ fromEnum c - fromEnum c1) <$> satisfy (\v -> c1 <= v && v <= c2) + black = PixelRGBA8 0 0 0 255 + + hexChar :: Parser Word8 + hexChar = charRange '0' '9' + <|> ((+ 10) <$> charRange 'a' 'f') + <|> ((+ 10) <$> charRange 'A' 'F') + + namedColor = do + str <- takeWhile1 (inClass "a-z") + return $ M.findWithDefault black str svgNamedColors + + percentToWord v = floor $ v * (255 / 100) + + numPercent = ((percentToWord <$> num) <* string "%") + <|> (floor <$> num) + + hexByte = (\h1 h2 -> h1 `unsafeShiftL` 4 .|. h2) + <$> hexChar <*> hexChar + + color = (\r g b -> PixelRGBA8 r g b 255) + <$> hexByte <*> hexByte <*> hexByte + rgbColor = (\r g b -> PixelRGBA8 r g b 255) + <$> (string "rgb(" *> numPercent) + <*> (commaWsp *> numPercent) + <*> (commaWsp *> numPercent <* skipSpace <* string ")") + + colorReduced = + (\r g b -> PixelRGBA8 (r * 17) (g * 17) (b * 17) 255) + <$> hexChar <*> hexChar <*> hexChar + + +textureSerializer :: Texture -> String +textureSerializer (ColorRef px) = colorSerializer px +textureSerializer (TextureRef str) = printf "url(#%s)" str +textureSerializer FillNone = "none" + +urlRef :: Parser String +urlRef = string "url(" *> skipSpace *> + char '#' *> many1 (letter <|> digit) + <* skipSpace <* char ')' <* skipSpace + + +textureParser :: Parser Texture +textureParser = + none <|> (TextureRef <$> urlRef) + <|> (ColorRef <$> colorParser) + where + none = FillNone <$ string "none" +
+ src/Graphics/Svg/CssParser.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +module Graphics.Svg.CssParser + ( CssElement( .. ) + , complexNumber + , declaration + , ruleSet + , styleString + , dashArray + , numberList + , num + , cssRulesOfText + ) + where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<*), (*>) + , pure + ) +#endif + +import Control.Applicative( (<$>), (<$) + , (<|>) + , many + ) +import Data.Attoparsec.Text + ( Parser + , double + , string + , skipSpace + , letter + , char + , digit + {-, skip-} + , sepBy1 + , (<?>) + , skipMany + , notChar + , parseOnly + ) +import qualified Data.Attoparsec.Text as AT + +import Data.Attoparsec.Combinator + ( option + , sepBy + {-, sepBy1-} + , many1 + ) + +import Codec.Picture( PixelRGBA8( .. ) ) +import Graphics.Svg.Types +import Graphics.Svg.NamedColors( svgNamedColors ) +import Graphics.Svg.ColorParser( colorParser ) +import Graphics.Svg.CssTypes +import qualified Data.Text as T +import qualified Data.Map as M +{-import Graphics.Rasterific.Linear( V2( V2 ) )-} +{-import Graphics.Rasterific.Transformations-} + +num :: Parser Float +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber = char '.' *> (scale <$> double) + <|> double + + scalingCoeff n = 10 ^ digitCount + where digitCount :: Int + digitCount = ceiling . logBase 10 $ abs n + + scale n = n / scalingCoeff n + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + + +ident :: Parser T.Text +ident = + (\f c -> f . T.cons c . T.pack) + <$> trailingSub + <*> nmstart <*> nmchar + where + trailingSub = option id $ T.cons '-' <$ char '-' + underscore = char '_' + nmstart = letter <|> underscore + nmchar = many (letter <|> digit <|> underscore <|> char '-') + +str :: Parser T.Text +str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace + <?> "str" + +between :: Char -> Char -> Parser a -> Parser a +between o e p = + (skipSpace *> + char o *> skipSpace *> p + <* skipSpace <* char e <* skipSpace) + <?> ("between " ++ [o, e]) + +bracket :: Parser a -> Parser a +bracket = between '[' ']' + + +comment :: Parser () +comment = string "/*" *> toStar *> skipSpace + where + toStar = skipMany (notChar '*') *> char '*' *> testEnd + testEnd = (() <$ char '/') <|> toStar + +cleanSpace :: Parser () +cleanSpace = skipSpace <* many comment + +-- | combinator: '+' S* | '>' S* +combinator :: Parser CssSelector +combinator = parse <* cleanSpace where + parse = Nearby <$ char '+' + <|> DirectChildren <$ char '>' + <?> "combinator" + +-- unary_operator : '-' | '+' ; + +commaWsp :: Parser Char +commaWsp = skipSpace *> option ',' (char ',') <* skipSpace + +ruleSet :: Parser CssRule +ruleSet = cleanSpace *> rule where + rule = CssRule + <$> selector `sepBy1` commaWsp + <*> (between '{' '}' styleString) + <?> "cssrule" + +styleString :: Parser [CssDeclaration] +styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp + <?> "styleString" + where semiWsp = skipSpace *> char ';' <* skipSpace + mayWsp = option ';' semiWsp + +selector :: Parser [CssSelector] +selector = (:) + <$> (AllOf <$> simpleSelector <* skipSpace <?> "firstpart:(") + <*> ((next <|> return []) <?> "secondpart") + <?> "selector" + where + combOpt :: Parser ([CssSelector] -> [CssSelector]) + + combOpt = cleanSpace *> option id ((:) <$> combinator) + next :: Parser [CssSelector] + next = id <$> combOpt <*> selector + +simpleSelector :: Parser [CssDescriptor] +simpleSelector = (:) <$> elementName <*> many whole + <|> (many1 whole <?> "inmany") + <?> "simple selector" + where + whole = pseudo <|> hash <|> classParser <|> attrib + <?> "whole" + pseudo = char ':' *> (OfPseudoClass <$> ident) + <?> "pseudo" + hash = char '#' *> (OfId <$> ident) + <?> "hash" + classParser = char '.' *> (OfClass <$> ident) + <?> "classParser" + + elementName = el <* skipSpace <?> "elementName" + where el = (OfName <$> ident) + <|> AnyElem <$ char '*' + + attrib = bracket + (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str)) + <?> "attrib") + +declaration :: Parser CssDeclaration +declaration = + CssDeclaration <$> property + <*> (char ':' + *> cleanSpace + *> many1 expr + <* prio + ) + <?> "declaration" + where + property = (ident <* cleanSpace) <?> "property" + prio = option "" $ string "!important" + +operator :: Parser CssElement +operator = skipSpace *> op <* skipSpace + where + op = CssOpSlash <$ char '/' + <|> CssOpComa <$ char ',' + <?> "operator" + +expr :: Parser [CssElement] +expr = ((:) <$> term <*> (concat <$> many termOp)) + <?> "expr" + where + op = option (:[]) $ (\a b -> [a, b]) <$> operator + termOp = ($) <$> op <*> term + +dashArray :: Parser [Number] +dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp) + +numberList :: Parser [Float] +numberList = skipSpace *> (num `sepBy1` commaWsp) + +complexNumber :: Parser Number +complexNumber = do + n <- num + (Percent (n / 100) <$ char '%') + <|> (Em n <$ string "em") + <|> (Mm n <$ string "mm") + <|> (Cm n <$ string "cm") + <|> (Point n <$ string "pt") + <|> (Pc n <$ string "pc") + <|> (Px n <$ string "px") + <|> (Inches n <$ string "in") + <|> pure (Num n) + +term :: Parser CssElement +term = checkRgb <$> function + <|> (CssNumber <$> complexNumber) + <|> (CssString <$> str) + <|> (checkNamedColor <$> ident) + <|> (CssColor <$> colorParser) + where + comma = skipSpace *> char ',' <* skipSpace + checkNamedColor n + | Just c <- M.lookup n svgNamedColors = CssColor c + | otherwise = CssIdent n + + ref = char '#' *> ident + + checkRgb (CssFunction "rgb" + [CssNumber r, CssNumber g, CssNumber b]) = + CssColor $ PixelRGBA8 (to r) (to g) (to b) 255 + where clamp = max 0 . min 255 + to (Num n) = floor $ clamp n + to (Px n) = floor $ clamp n + to (Percent p) = floor . clamp $ p * 255 + to (Em c) = floor $ clamp c + to (Pc n) = floor $ clamp n + to (Mm n) = floor $ clamp n + to (Cm n) = floor $ clamp n + to (Point n) = floor $ clamp n + to (Inches n) = floor $ clamp n + + checkRgb a = a + functionParam = (CssReference <$> ref) <|> term + + function = CssFunction + <$> ident <* char '(' + <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace + +-- | Parse CSS text into rules. +cssRulesOfText :: T.Text -> [CssRule] +cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of + Left _ -> [] + Right rules -> rules +
+ src/Graphics/Svg/CssTypes.hs view
@@ -0,0 +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( .. ) ) +{-import Debug.Trace-} + +-- | 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 . intersperse (si ' ') $ 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" + tselectors = + intersperse (ft ",\n") . fmap tserialize $ concat 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) (AllOf descr : rest) + | isDescribedBy e descr = go upper rest + | otherwise = False + 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 Float -- ^ Simple coordinate in current user coordinate. + | Px Float -- ^ With suffix "px" + | Em Float -- ^ Number relative to the current font size. + | Percent Float -- ^ Number relative to the current viewport size. + | Pc Float + | Mm Float -- ^ Number in millimeters, relative to DPI. + | Cm Float -- ^ Number in centimeters, relative to DPI. + | Point Float -- ^ Number in points, relative to DPI. + | Inches Float -- ^ Number in inches, relative to DPI. + deriving (Eq, Show) + +-- | Helper function to modify inner value of a number +mapNumber :: (Float -> Float) -> 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 +
+ src/Graphics/Svg/NamedColors.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedStrings #-} +module Graphics.Svg.NamedColors( svgNamedColors ) where + +import qualified Data.Map as M +import Codec.Picture( PixelRGBA8( .. ) ) +import Data.Text( Text ) + +svgNamedColors :: M.Map Text PixelRGBA8 +svgNamedColors = M.fromList + [ ("aliceblue" , PixelRGBA8 240 248 255 255) + , ("antiquewhite" , PixelRGBA8 250 235 215 255) + , ("aqua" , PixelRGBA8 0 255 255 255) + , ("aquamarine" , PixelRGBA8 127 255 212 255) + , ("azure" , PixelRGBA8 240 255 255 255) + , ("beige" , PixelRGBA8 245 245 220 255) + , ("bisque" , PixelRGBA8 255 228 196 255) + , ("black" , PixelRGBA8 0 0 0 255) + , ("blanchedalmond" , PixelRGBA8 255 235 205 255) + , ("blue" , PixelRGBA8 0 0 255 255) + , ("blueviolet" , PixelRGBA8 138 43 226 255) + , ("brown" , PixelRGBA8 165 42 42 255) + , ("burlywood" , PixelRGBA8 222 184 135 255) + , ("cadetblue" , PixelRGBA8 95 158 160 255) + , ("chartreuse" , PixelRGBA8 127 255 0 255) + , ("chocolate" , PixelRGBA8 210 105 30 255) + , ("coral" , PixelRGBA8 255 127 80 255) + , ("cornflowerblue" , PixelRGBA8 100 149 237 255) + , ("cornsilk" , PixelRGBA8 255 248 220 255) + , ("crimson" , PixelRGBA8 220 20 60 255) + , ("cyan" , PixelRGBA8 0 255 255 255) + , ("darkblue" , PixelRGBA8 0 0 139 255) + , ("darkcyan" , PixelRGBA8 0 139 139 255) + , ("darkgoldenrod" , PixelRGBA8 184 134 11 255) + , ("darkgray" , PixelRGBA8 169 169 169 255) + , ("darkgreen" , PixelRGBA8 0 100 0 255) + , ("darkgrey" , PixelRGBA8 169 169 169 255) + , ("darkkhaki" , PixelRGBA8 189 183 107 255) + , ("darkmagenta" , PixelRGBA8 139 0 139 255) + , ("darkolivegreen" , PixelRGBA8 85 107 47 255) + , ("darkorange" , PixelRGBA8 255 140 0 255) + , ("darkorchid" , PixelRGBA8 153 50 204 255) + , ("darkred" , PixelRGBA8 139 0 0 255) + , ("darksalmon" , PixelRGBA8 233 150 122 255) + , ("darkseagreen" , PixelRGBA8 143 188 143 255) + , ("darkslateblue" , PixelRGBA8 72 61 139 255) + , ("darkslategray" , PixelRGBA8 47 79 79 255) + , ("darkslategrey" , PixelRGBA8 47 79 79 255) + , ("darkturquoise" , PixelRGBA8 0 206 209 255) + , ("darkviolet" , PixelRGBA8 148 0 211 255) + , ("deeppink" , PixelRGBA8 255 20 147 255) + , ("deepskyblue" , PixelRGBA8 0 191 255 255) + , ("dimgray" , PixelRGBA8 105 105 105 255) + , ("dimgrey" , PixelRGBA8 105 105 105 255) + , ("dodgerblue" , PixelRGBA8 30 144 255 255) + , ("firebrick" , PixelRGBA8 178 34 34 255) + , ("floralwhite" , PixelRGBA8 255 250 240 255) + , ("forestgreen" , PixelRGBA8 34 139 34 255) + , ("fuchsia" , PixelRGBA8 255 0 255 255) + , ("gainsboro" , PixelRGBA8 220 220 220 255) + , ("ghostwhite" , PixelRGBA8 248 248 255 255) + , ("gold" , PixelRGBA8 255 215 0 255) + , ("goldenrod" , PixelRGBA8 218 165 32 255) + , ("gray" , PixelRGBA8 128 128 128 255) + , ("grey" , PixelRGBA8 128 128 128 255) + , ("green" , PixelRGBA8 0 128 0 255) + , ("greenyellow" , PixelRGBA8 173 255 47 255) + , ("honeydew" , PixelRGBA8 240 255 240 255) + , ("hotpink" , PixelRGBA8 255 105 180 255) + , ("indianred" , PixelRGBA8 205 92 92 255) + , ("indigo" , PixelRGBA8 75 0 130 255) + , ("ivory" , PixelRGBA8 255 255 240 255) + , ("khaki" , PixelRGBA8 240 230 140 255) + , ("lavender" , PixelRGBA8 230 230 250 255) + , ("lavenderblush" , PixelRGBA8 255 240 245 255) + , ("lawngreen" , PixelRGBA8 124 252 0 255) + , ("lemonchiffon" , PixelRGBA8 255 250 205 255) + , ("lightblue" , PixelRGBA8 173 216 230 255) + , ("lightcoral" , PixelRGBA8 240 128 128 255) + , ("lightcyan" , PixelRGBA8 224 255 255 255) + , ("lightgoldenrodyellow", PixelRGBA8 250 250 210 255) + , ("lightgray" , PixelRGBA8 211 211 211 255) + , ("lightgreen" , PixelRGBA8 144 238 144 255) + , ("lightgrey" , PixelRGBA8 211 211 211 255) + , ("lightpink" , PixelRGBA8 255 182 193 255) + , ("lightsalmon" , PixelRGBA8 255 160 122 255) + , ("lightseagreen" , PixelRGBA8 32 178 170 255) + , ("lightskyblue" , PixelRGBA8 135 206 250 255) + , ("lightslategray" , PixelRGBA8 119 136 153 255) + , ("lightslategrey" , PixelRGBA8 119 136 153 255) + , ("lightsteelblue" , PixelRGBA8 176 196 222 255) + , ("lightyellow" , PixelRGBA8 255 255 224 255) + , ("lime" , PixelRGBA8 0 255 0 255) + , ("limegreen" , PixelRGBA8 50 205 50 255) + , ("linen" , PixelRGBA8 250 240 230 255) + , ("magenta" , PixelRGBA8 255 0 255 255) + , ("maroon" , PixelRGBA8 128 0 0 255) + , ("mediumaquamarine" , PixelRGBA8 102 205 170 255) + , ("mediumblue" , PixelRGBA8 0 0 205 255) + , ("mediumorchid" , PixelRGBA8 186 85 211 255) + , ("mediumpurple" , PixelRGBA8 147 112 219 255) + , ("mediumseagreen" , PixelRGBA8 60 179 113 255) + , ("mediumslateblue" , PixelRGBA8 123 104 238 255) + , ("mediumspringgreen" , PixelRGBA8 0 250 154 255) + , ("mediumturquoise" , PixelRGBA8 72 209 204 255) + , ("mediumvioletred" , PixelRGBA8 199 21 133 255) + , ("midnightblue" , PixelRGBA8 25 25 112 255) + , ("mintcream" , PixelRGBA8 245 255 250 255) + , ("mistyrose" , PixelRGBA8 255 228 225 255) + , ("moccasin" , PixelRGBA8 255 228 181 255) + , ("navajowhite" , PixelRGBA8 255 222 173 255) + , ("navy" , PixelRGBA8 0 0 128 255) + , ("oldlace" , PixelRGBA8 253 245 230 255) + , ("olive" , PixelRGBA8 128 128 0 255) + , ("olivedrab" , PixelRGBA8 107 142 35 255) + , ("orange" , PixelRGBA8 255 165 0 255) + , ("orangered" , PixelRGBA8 255 69 0 255) + , ("orchid" , PixelRGBA8 218 112 214 255) + , ("palegoldenrod" , PixelRGBA8 238 232 170 255) + , ("palegreen" , PixelRGBA8 152 251 152 255) + , ("paleturquoise" , PixelRGBA8 175 238 238 255) + , ("palevioletred" , PixelRGBA8 219 112 147 255) + , ("papayawhip" , PixelRGBA8 255 239 213 255) + , ("peachpuff" , PixelRGBA8 255 218 185 255) + , ("peru" , PixelRGBA8 205 133 63 255) + , ("pink" , PixelRGBA8 255 192 203 255) + , ("plum" , PixelRGBA8 221 160 221 255) + , ("powderblue" , PixelRGBA8 176 224 230 255) + , ("purple" , PixelRGBA8 128 0 128 255) + , ("red" , PixelRGBA8 255 0 0 255) + , ("rosybrown" , PixelRGBA8 188 143 143 255) + , ("royalblue" , PixelRGBA8 65 105 225 255) + , ("saddlebrown" , PixelRGBA8 139 69 19 255) + , ("salmon" , PixelRGBA8 250 128 114 255) + , ("sandybrown" , PixelRGBA8 244 164 96 255) + , ("seagreen" , PixelRGBA8 46 139 87 255) + , ("seashell" , PixelRGBA8 255 245 238 255) + , ("sienna" , PixelRGBA8 160 82 45 255) + , ("silver" , PixelRGBA8 192 192 192 255) + , ("skyblue" , PixelRGBA8 135 206 235 255) + , ("slateblue" , PixelRGBA8 106 90 205 255) + , ("slategray" , PixelRGBA8 112 128 144 255) + , ("slategrey" , PixelRGBA8 112 128 144 255) + , ("snow" , PixelRGBA8 255 250 250 255) + , ("springgreen" , PixelRGBA8 0 255 127 255) + , ("steelblue" , PixelRGBA8 70 130 180 255) + , ("tan" , PixelRGBA8 210 180 140 255) + , ("teal" , PixelRGBA8 0 128 128 255) + , ("thistle" , PixelRGBA8 216 191 216 255) + , ("tomato" , PixelRGBA8 255 99 71 255) + , ("turquoise" , PixelRGBA8 64 224 208 255) + , ("violet" , PixelRGBA8 238 130 238 255) + , ("wheat" , PixelRGBA8 245 222 179 255) + , ("white" , PixelRGBA8 255 255 255 255) + , ("whitesmoke" , PixelRGBA8 245 245 245 255) + , ("yellow" , PixelRGBA8 255 255 0 255) + , ("yellowgreen" , PixelRGBA8 154 205 50 255) + ] +
+ src/Graphics/Svg/PathParser.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Graphics.Svg.PathParser( transformParser + , command + , viewBoxParser + , pointData + , serializePoints + , serializeCommand + , serializeCommands + , serializeViewBox + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<*), (*>) ) +#endif + +import Control.Applicative( (<$>), (<$), (<|>) ) +import Data.Scientific( toRealFloat ) +import Data.Attoparsec.Text + ( Parser + , scientific + , string + , skipSpace + , char + ) +import Data.Attoparsec.Combinator( option + , sepBy + , sepBy1 ) + +import Linear hiding ( angle, point ) +import Graphics.Svg.Types +import qualified Data.Text as T +import Text.Printf( printf ) + +num :: Parser Float +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber :: Parser Float + doubleNumber = toRealFloat <$> scientific + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + +viewBoxParser :: Parser (Int, Int, Int, Int) +viewBoxParser = (,,,) + <$> iParse <*> iParse <*> iParse <*> iParse + where + iParse = floor <$> num <* skipSpace + +serializeViewBox :: (Int, Int, Int, Int) -> String +serializeViewBox (a, b, c, d) = printf "%d %d %d %d" a b c d + +commaWsp :: Parser () +commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace + +point :: Parser RPoint +point = V2 <$> num <* commaWsp <*> num + +pointData :: Parser [RPoint] +pointData = point `sepBy` commaWsp + +command :: Parser PathCommand +command = (MoveTo OriginAbsolute <$ string "M" <*> pointList) + <|> (MoveTo OriginRelative <$ string "m" <*> pointList) + <|> (LineTo OriginAbsolute <$ string "L" <*> pointList) + <|> (LineTo OriginRelative <$ string "l" <*> pointList) + <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList) + <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList) + <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList) + <|> (VerticalTo OriginRelative <$ string "v" <*> coordList) + <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs) + <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs) + <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList) + <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList) + <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList) + <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList) + <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList) + <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList) + <|> (ElipticalArc OriginAbsolute <$ string "A" <*> manyComma elipticalArgs) + <|> (ElipticalArc OriginRelative <$ string "a" <*> manyComma elipticalArgs) + <|> (EndPath <$ string "Z") + <|> (EndPath <$ string "z") + where pointList = point `sepBy1` commaWsp + pointPair = (,) <$> point <* commaWsp <*> point + pointPairList = pointPair `sepBy1` commaWsp + coordList = num `sepBy1` commaWsp + curveToArgs = (,,) <$> (point <* commaWsp) + <*> (point <* commaWsp) + <*> point + manyComma a = a `sepBy1` commaWsp + + numComma = num <* commaWsp + elipticalArgs = (,,,,,) <$> numComma + <*> numComma + <*> numComma + <*> numComma + <*> numComma + <*> point + +serializePoint :: RPoint -> String +serializePoint (V2 x y) = printf "%g,%g" x y + +serializePoints :: [RPoint] -> String +serializePoints = unwords . fmap serializePoint + +serializeCoords :: [Coord] -> String +serializeCoords = unwords . fmap (printf "%g") + +serializePointPair :: (RPoint, RPoint) -> String +serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b + +serializePointPairs :: [(RPoint, RPoint)] -> String +serializePointPairs = unwords . fmap serializePointPair + +serializePointTriplet :: (RPoint, RPoint, RPoint) -> String +serializePointTriplet (a, b, c) = + serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c + +serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String +serializePointTriplets = unwords . fmap serializePointTriplet + +serializeCommands :: [PathCommand] -> String +serializeCommands = unwords . fmap serializeCommand + +serializeCommand :: PathCommand -> String +serializeCommand p = case p of + MoveTo OriginAbsolute points -> "M" ++ serializePoints points + MoveTo OriginRelative points -> "m" ++ serializePoints points + LineTo OriginAbsolute points -> "L" ++ serializePoints points + LineTo OriginRelative points -> "l" ++ serializePoints points + + HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords + HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords + VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords + VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords + + CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets + CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets + SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs + SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs + QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs + QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs + SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points + SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points + ElipticalArc OriginAbsolute args -> "A" ++ serializeArgs args + ElipticalArc OriginRelative args -> "a" ++ serializeArgs args + EndPath -> "Z" + where + serializeArg (a, b, c, d, e, V2 x y) = + printf "%g %g %g %g %g %g,%g" a b c d e x y + serializeArgs = unwords . fmap serializeArg + + + +transformParser :: Parser Transformation +transformParser = matrixParser + <|> translationParser + <|> scaleParser + <|> rotateParser + <|> skewYParser + <|> skewXParser + +functionParser :: T.Text -> Parser [Float] +functionParser funcName = + string funcName *> skipSpace + *> char '(' *> skipSpace + *> num `sepBy1` commaWsp + <* skipSpace <* char ')' <* skipSpace + +translationParser :: Parser Transformation +translationParser = do + args <- functionParser "translate" + return $ case args of + [x] -> Translate x 0 + [x, y] -> Translate x y + _ -> TransformUnknown + +skewXParser :: Parser Transformation +skewXParser = do + args <- functionParser "skewX" + return $ case args of + [x] -> SkewX x + _ -> TransformUnknown + +skewYParser :: Parser Transformation +skewYParser = do + args <- functionParser "skewY" + return $ case args of + [x] -> SkewY x + _ -> TransformUnknown + + +scaleParser :: Parser Transformation +scaleParser = do + args <- functionParser "scale" + return $ case args of + [x] -> Scale x Nothing + [x, y] -> Scale x (Just y) + _ -> TransformUnknown + +matrixParser :: Parser Transformation +matrixParser = do + args <- functionParser "matrix" + return $ case args of + [a, b, c, d, e, f] -> + TransformMatrix a b c d e f + _ -> TransformUnknown + +rotateParser :: Parser Transformation +rotateParser = do + args <- functionParser "rotate" + return $ case args of + [angle] -> Rotate angle Nothing + [angle, x, y] -> Rotate angle $ Just (x, y) + _ -> TransformUnknown +{- +rotate(<rotate-angle> [<cx> <cy>]), which specifies a rotation by <rotate-angle> degrees about a given point. + +If optional parameters <cx> and <cy> 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 <cx> and <cy> are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(<cx>, <cy>) rotate(<rotate-angle>) translate(-<cx>, -<cy>). + +skewX(<skew-angle>), which specifies a skew transformation along the x-axis. + +skewY(<skew-angle>), which specifies a skew transformation along the y-axis. + -}
+ src/Graphics/Svg/Types.hs view
@@ -0,0 +1,1452 @@+{-# 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( .. ) + , 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( .. ) + + -- * 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 = Float + +-- | 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. + | ElipticalArc Origin [(Coord, Coord, Coord, Coord, Coord, 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 ElipticalArc. +isPathArc :: PathCommand -> Bool +isPathArc (ElipticalArc _ _) = True +isPathArc _ = False + +-- | Tell if a full path contain an ElipticalArc. +isPathWithArc :: Foldable f => f PathCommand -> Bool +isPathWithArc = F.any isPathArc + + +-- | 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 Float Float + -- | Scaling on both axis or on X axis and Y axis. + | Scale Float (Maybe Float) + -- | Rotation around `(0, 0)` or around an optional + -- point. + | Rotate Float (Maybe (Float, Float)) + -- | Skew transformation along the X axis. + | SkewX Float + -- | Skew transformation along the Y axis. + | SkewY Float + -- | 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 Float) + -- | 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) + + -- | 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 `<polyline>` 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 `<polygon>` +-- 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 +-- `<line>` 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 +-- `<rectangle>` 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 `<path>` 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 `<g>` 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 `<g>` tag. + , _groupChildren :: ![a] + -- | Mapped to the attribute `viewBox` + , _groupViewBox :: !(Maybe (Int, Int, Int, Int)) + } + 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 + } + +-- | Define the `<symbol>` 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 `<circle>`. +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 `<ellipse>` +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 `<image>` 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 + } + 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 = "" + } + +-- | Define an `<use>` 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 +-- `<text>` or `<tspan>` svg tag. +data TextInfo = TextInfo + { _textInfoX :: ![Number] -- ^ `x` attribute. + , _textInfoY :: ![Number] -- ^ `y` attribute. + , _textInfoDX :: ![Number] -- ^ `dx` attribute. + , _textInfoDY :: ![Number] -- ^ `dy` attribute. + , _textInfoRotate :: ![Float] -- ^ `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 `<tspan>` tag. +data TextSpanContent + = SpanText !T.Text -- ^ Raw text + | SpanTextRef !String -- ^ Equivalent to a `<tref>` + | SpanSub !TextSpan -- ^ Define a `<tspan>` + deriving (Eq, Show) + +-- | Define a `<tspan>` 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 `<textpath>` 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 `<tag>` 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 `<marker>` 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 (Int, Int, Int, Int)) + -- | 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 + , _markerElements = mempty + } + +-- | 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 `<stop>` 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 `<linearGradient>` 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 `<radialGradient>` 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 `<mask>` 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 `<mask>` 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 `<clipPath>` 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 `<pattern>` tag. +data Pattern = Pattern + { -- | Pattern drawing attributes. + _patternDrawAttributes :: DrawAttributes + -- | Possible `viewBox`. + , _patternViewBox :: Maybe (Int, Int, Int, Int) + -- | 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 + } + 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 + } + +-- | 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 (Int, Int, Int, Int) + , _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 = fromIntegral . abs $ x2 - x1 + dy = fromIntegral . 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) } = + (abs $ x2 - x1, 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 + , _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 + , _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 +
+ src/Graphics/Svg/XmlParser.hs view
@@ -0,0 +1,1077 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Graphics.Svg.XmlParser( xmlOfDocument + , unparseDocument + + , SvgAttributeLens( .. ) + , drawAttributesList + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure ) +import Data.Foldable( foldMap ) +import Data.Monoid( mempty ) +#endif + +import Control.Applicative( (<$>), (<$), (<|>), many ) + +import Control.Lens hiding( transform, children, elements, element ) +import Control.Monad.State.Strict( State, runState, modify, gets ) +import Data.Maybe( catMaybes ) +import Data.Monoid( Last( Last ), getLast, (<>) ) +import Data.List( foldl', intercalate ) +import Text.XML.Light.Proc( findAttrBy, elChildren, strContent ) +import Text.Read( readMaybe ) +import qualified Text.XML.Light as X +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Map as M +import Data.Attoparsec.Text( Parser, string, parseOnly, many1 ) +import Codec.Picture( PixelRGBA8( .. ) ) +import Graphics.Svg.Types +import Graphics.Svg.PathParser +import Graphics.Svg.ColorParser +import Graphics.Svg.CssTypes( CssDeclaration( .. ) + , CssElement( .. ) + , CssRule + , tserialize + ) +import Graphics.Svg.CssParser( complexNumber + , num + , ruleSet + , dashArray + , styleString + , numberList ) + +import Text.Printf( printf ) + +{-import Debug.Trace-} + +nodeName :: X.Element -> String +nodeName = X.qName . X.elName + +attributeFinder :: String -> X.Element -> Maybe String +attributeFinder str = + findAttrBy (\a -> X.qName a == str) + +-- | Helper class to help simplify parsing code +-- for various attributes. +class ParseableAttribute a where + aparse :: String -> Maybe a + aserialize :: a -> Maybe String + +instance ParseableAttribute v => ParseableAttribute (Maybe v) where + aparse = fmap Just . aparse + aserialize = (>>= aserialize) + +instance ParseableAttribute v => ParseableAttribute (Last v) where + aparse = fmap Last . aparse + aserialize = aserialize . getLast + +instance ParseableAttribute String where + aparse = Just + aserialize = Just + +instance ParseableAttribute Number where + aparse = parseMayStartDot complexNumber + aserialize = Just . serializeNumber + +instance ParseableAttribute [Number] where + aparse = parse dashArray + aserialize = Just . serializeDashArray + +instance ParseableAttribute PixelRGBA8 where + aparse = parse colorParser + aserialize = Just . colorSerializer + +instance ParseableAttribute [PathCommand] where + aparse = parse $ many1 command + aserialize = Just . serializeCommands + +instance ParseableAttribute [RPoint] where + aparse = parse pointData + aserialize = Just . serializePoints + +instance ParseableAttribute Float where + aparse = parseMayStartDot num + aserialize v = Just $ printf "%g" v + +instance ParseableAttribute Texture where + aparse = parse textureParser + aserialize = Just . textureSerializer + +instance ParseableAttribute [Transformation] where + aparse = parse $ many transformParser + aserialize = Just . serializeTransformations + +instance ParseableAttribute Cap where + aparse s = case s of + "butt" -> Just CapButt + "round" -> Just CapRound + "square" -> Just CapSquare + _ -> Nothing + + aserialize c = Just $ case c of + CapButt -> "butt" + CapRound -> "round" + CapSquare -> "square" + +instance ParseableAttribute TextAnchor where + aparse s = case s of + "middle" -> Just TextAnchorMiddle + "start" -> Just TextAnchorStart + "end" -> Just TextAnchorEnd + _ -> Nothing + + aserialize t = Just $ case t of + TextAnchorMiddle -> "middle" + TextAnchorStart -> "start" + TextAnchorEnd -> "end" + +instance ParseableAttribute ElementRef where + aparse s = case parseOnly pa $ T.pack s of + Left _ -> Nothing + Right v -> Just v + where + pa = (RefNone <$ string "none") + <|> (Ref <$> urlRef) + + aserialize c = Just $ case c of + Ref r -> "url(#" <> r <> ")" + RefNone -> "none" + +instance ParseableAttribute LineJoin where + aparse s = case s of + "miter" -> Just JoinMiter + "round" -> Just JoinRound + "bevel" -> Just JoinBevel + _ -> Nothing + + aserialize j = Just $ case j of + JoinMiter -> "miter" + JoinRound -> "round" + JoinBevel -> "bevel" + +instance ParseableAttribute CoordinateUnits where + aparse s = case s of + "userSpaceOnUse" -> Just CoordUserSpace + "objectBoundingBox" -> Just CoordBoundingBox + _ -> Just CoordBoundingBox + + aserialize uni = Just $ case uni of + CoordUserSpace -> "userSpaceOnUse" + CoordBoundingBox -> "objectBoundingBox" + +instance ParseableAttribute Spread where + aparse s = case s of + "pad" -> Just SpreadPad + "reflect" -> Just SpreadReflect + "repeat" -> Just SpreadRepeat + _ -> Nothing + + aserialize s = Just $ case s of + SpreadPad -> "pad" + SpreadReflect -> "reflect" + SpreadRepeat -> "repeat" + +instance ParseableAttribute FillRule where + aparse s = case s of + "nonzero" -> Just FillNonZero + "evenodd" -> Just FillEvenOdd + _ -> Nothing + + aserialize f = Just $ case f of + FillNonZero -> "nonzero" + FillEvenOdd -> "evenodd" + +instance ParseableAttribute TextAdjust where + aparse s = Just $ case s of + "spacing" -> TextAdjustSpacing + "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs + _ -> TextAdjustSpacing + + aserialize a = Just $ case a of + TextAdjustSpacing -> "spacing" + TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs" + +instance ParseableAttribute MarkerUnit where + aparse s = case s of + "strokeWidth" -> Just MarkerUnitStrokeWidth + "userSpaceOnUse" -> Just MarkerUnitUserSpaceOnUse + _ -> Nothing + + aserialize u = Just $ case u of + MarkerUnitStrokeWidth -> "strokeWidth" + MarkerUnitUserSpaceOnUse -> "userSpaceOnUse" + +instance ParseableAttribute MarkerOrientation where + aparse s = case (s, readMaybe s) of + ("auto", _) -> Just OrientationAuto + (_, Just f) -> Just $ OrientationAngle f + _ -> Nothing + + aserialize s = Just $ case s of + OrientationAuto -> "auto" + OrientationAngle f -> show f + +instance ParseableAttribute (Int, Int, Int, Int) where + aparse = parse viewBoxParser + aserialize = Just . serializeViewBox + +instance ParseableAttribute TextPathMethod where + aparse s = case s of + "align" -> Just TextPathAlign + "stretch" -> Just TextPathStretch + _ -> Nothing + aserialize m = Just $ case m of + TextPathAlign -> "align" + TextPathStretch -> "stretch" + +instance ParseableAttribute TextPathSpacing where + aparse s = case s of + "auto" -> Just TextPathSpacingAuto + "exact" -> Just TextPathSpacingExact + _ -> Nothing + + aserialize s = Just $ case s of + TextPathSpacingAuto -> "auto" + TextPathSpacingExact -> "exact" + +parse :: Parser a -> String -> Maybe a +parse p str = case parseOnly p (T.pack str) of + Left _ -> Nothing + Right r -> Just r + +parseMayStartDot :: Parser a -> String -> Maybe a +parseMayStartDot p l@('.':_) = parse p ('0':l) +parseMayStartDot p l = parse p l + +xmlUpdate :: (XMLUpdatable a) => a -> X.Element -> a +xmlUpdate initial el = foldl' grab initial attributes + where + grab value updater = + case attributeFinder (_attributeName updater) el of + Nothing -> value + Just v -> _attributeUpdater updater value v + +xmlUnparse :: (XMLUpdatable a) => X.Element -> a +xmlUnparse = xmlUpdate defaultSvg + +xmlUnparseWithDrawAttr + :: (XMLUpdatable a, WithDrawAttributes a) + => X.Element -> a +xmlUnparseWithDrawAttr e = + xmlUnparse e & drawAttr .~ xmlUnparse e + +data SvgAttributeLens t = SvgAttributeLens + { _attributeName :: String + , _attributeUpdater :: t -> String -> t + , _attributeSerializer :: t -> Maybe String + } + +class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where + xmlTagName :: treeNode -> String + attributes :: [SvgAttributeLens treeNode] + + serializeTreeNode :: treeNode -> X.Element + +setChildren :: X.Element -> [X.Content] -> X.Element +setChildren xNode children = xNode { X.elContent = children } + +updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> X.Element -> X.Element +updateWithAccessor accessor node xNode = + setChildren xNode $ X.Elem . serializeTreeNode <$> accessor node + +genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> X.Element +genericSerializeNode node = + X.unode (xmlTagName node) $ concatMap generateAttribute attributes + where + generateAttribute attr = case _attributeSerializer attr node of + Nothing -> [] + Just str -> return X.Attr + { X.attrKey = xName $ _attributeName attr + , X.attrVal = str + } + where + xName "href" = + X.QName { X.qName = "href" + , X.qURI = Nothing + , X.qPrefix = Just "xlink" } + xName h = X.unqual h + + +mergeAttributes :: X.Element -> X.Element -> X.Element +mergeAttributes thisXml otherXml = + thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml } + +genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode) + => treeNode -> X.Element +genericSerializeWithDrawAttr node = mergeAttributes thisXml drawAttrNode where + thisXml = genericSerializeNode node + drawAttrNode = genericSerializeNode $ node ^. drawAttr + +type CssUpdater = + DrawAttributes -> [[CssElement]] -> DrawAttributes + +groupOpacitySetter :: SvgAttributeLens DrawAttributes +groupOpacitySetter = SvgAttributeLens "opacity" updater serializer + where + updater el str = case parseMayStartDot num str of + Nothing -> el + Just v -> (el & fillOpacity .~ Just v) & strokeOpacity .~ Just v + + serializer a = case (a ^. fillOpacity, a ^. strokeOpacity) of + (Just v, Just b) | v == b -> Just $ printf "%g" v + _ -> Nothing + +opacitySetter :: String -> Lens' a (Maybe Float) -> Lens' a (Maybe Float) + -> SvgAttributeLens a +opacitySetter attribute elLens otherLens = + SvgAttributeLens attribute updater serializer + where + updater el str = case parseMayStartDot num str of + Nothing -> el + Just v -> el & elLens .~ Just v + + serializer a = case (a ^. elLens, a ^. otherLens) of + (Just v, Just b) | v == b -> Nothing + (Just v, _) -> Just $ printf "%g" v + (Nothing, _) -> Nothing + +type Serializer e = e -> Maybe String + +parserSetter :: String -> Lens' a e -> (String -> Maybe e) -> Serializer e + -> SvgAttributeLens a +parserSetter attribute elLens parser serialize = + SvgAttributeLens attribute updater serializer + where + updater el str = case parser str of + Nothing -> el + Just v -> el & elLens .~ v + + serializer a = serialize $ a ^. elLens + +parseIn :: (Eq a, WithDefaultSvg s, ParseableAttribute a) + => String -> Lens' s a -> SvgAttributeLens s +parseIn attribute elLens = + SvgAttributeLens attribute updater serializer + where + updater el str = case aparse str of + Nothing -> el + Just v -> el & elLens .~ v + + serializer a + | v /= defaultVal = aserialize v + | otherwise = Nothing + where + v = a ^. elLens + defaultVal = defaultSvg ^. elLens + +parserLastSetter :: String -> Lens' a (Last e) -> (String -> Maybe e) -> Serializer e + -> SvgAttributeLens a +parserLastSetter attribute elLens parser serialize = + SvgAttributeLens attribute updater serializer + where + updater el str = case parser str of + Nothing -> el + Just v -> el & elLens .~ Last (Just v) + + serializer a = getLast (a ^. elLens) >>= serialize + +classSetter :: SvgAttributeLens DrawAttributes +classSetter = SvgAttributeLens "class" updater serializer + where + updater el str = + el & attrClass .~ (T.split (== ' ') $ T.pack str) + + serializer a = + Just . T.unpack . T.intercalate " " $ a ^. attrClass + +cssUniqueNumber :: ASetter DrawAttributes DrawAttributes + a (Last Number) + -> CssUpdater +cssUniqueNumber setter attr ((CssNumber n:_):_) = + attr & setter .~ Last (Just n) +cssUniqueNumber _ attr _ = attr + +cssUniqueFloat :: ASetter DrawAttributes DrawAttributes a (Maybe Float) + -> CssUpdater +cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = + attr & setter .~ Just n +cssUniqueFloat _ attr _ = attr + +cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Float) + -> CssUpdater +cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) = + attr & setter .~ Last (Just n) +cssUniqueMayFloat _ attr _ = attr + +cssIdentAttr :: ParseableAttribute a => Lens' DrawAttributes a -> CssUpdater +cssIdentAttr setter attr ((CssIdent i:_):_) = case aparse $ T.unpack i of + Nothing -> attr + Just v -> attr & setter .~ v +cssIdentAttr _ attr _ = attr + +fontFamilyParser :: CssUpdater +fontFamilyParser attr (lst:_) = attr & fontFamily .~ fontNames + where + fontNames = Last . Just $ T.unpack <$> extractString lst + + extractString [] = [] + extractString (CssIdent n:rest) = n : extractString rest + extractString (CssString n:rest) = n : extractString rest + extractString (_:rest) = extractString rest +fontFamilyParser attr _ = attr + + +cssUniqueTexture :: ASetter DrawAttributes DrawAttributes + a (Last Texture) + -> CssUpdater +cssUniqueTexture setter attr ((CssIdent "none":_):_) = + attr & setter .~ Last (Just FillNone) +cssUniqueTexture setter attr ((CssColor c:_):_) = + attr & setter .~ Last (Just $ ColorRef c) +cssUniqueTexture setter attr ((CssFunction "url" [CssReference c]:_):_) = + attr & setter .~ Last (Just . TextureRef $ T.unpack c) +cssUniqueTexture _ attr _ = attr + +cssElementRefSetter :: Lens' DrawAttributes (Last ElementRef) + -> CssUpdater +cssElementRefSetter setter attr ((CssFunction "url" [CssReference c]:_):_) = + attr & setter .~ Last (Just . Ref $ T.unpack c) +cssElementRefSetter setter attr ((CssIdent "none":_):_) = + attr & setter .~ Last (Just RefNone) +cssElementRefSetter _ attr _ = attr + +cssMayStringSetter :: ASetter DrawAttributes DrawAttributes a (Maybe String) + -> CssUpdater +cssMayStringSetter setter attr ((CssIdent i:_):_) = + attr & setter .~ Just (T.unpack i) +cssMayStringSetter setter attr ((CssString i:_):_) = + attr & setter .~ Just (T.unpack i) +cssMayStringSetter _ attr _ = attr + +cssNullSetter :: CssUpdater +cssNullSetter attr _ = attr + +cssDashArray :: ASetter DrawAttributes DrawAttributes a (Last [Number]) + -> CssUpdater +cssDashArray setter attr (lst:_) = + case [n | CssNumber n <- lst ] of + [] -> attr + v -> attr & setter .~ Last (Just v) +cssDashArray _ attr _ = attr + + +drawAttributesList :: [(SvgAttributeLens DrawAttributes, CssUpdater)] +drawAttributesList = + [("stroke-width" `parseIn` strokeWidth, cssUniqueNumber strokeWidth) + ,("stroke" `parseIn` strokeColor, cssUniqueTexture strokeColor) + ,("fill" `parseIn` fillColor, cssUniqueTexture fillColor) + ,("stroke-linecap" `parseIn` strokeLineCap, cssIdentAttr strokeLineCap) + ,("stroke-linejoin" `parseIn` strokeLineJoin, cssIdentAttr strokeLineJoin) + ,("stroke-miterlimit" `parseIn` strokeMiterLimit, + cssUniqueMayFloat strokeMiterLimit) + + ,("transform" `parseIn` transform, const) + ,(groupOpacitySetter, cssUniqueFloat fillOpacity) + ,(opacitySetter "fill-opacity" fillOpacity strokeOpacity, + cssUniqueFloat fillOpacity) + ,(opacitySetter "stroke-opacity" strokeOpacity fillOpacity, + cssUniqueFloat strokeOpacity) + ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize) + ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate) + (Just . intercalate ", "), fontFamilyParser) + + ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule) + ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule) + ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef) + ,(classSetter, cssNullSetter) -- can't set class in CSS + ,("id" `parseIn` attrId, cssMayStringSetter attrId) + ,("stroke-dashoffset" `parseIn` strokeOffset, + cssUniqueNumber strokeOffset) + ,("stroke-dasharray" `parseIn` strokeDashArray, cssDashArray strokeDashArray) + ,("text-anchor" `parseIn` textAnchor, cssIdentAttr textAnchor) + ,("clip-path" `parseIn` clipPathRef, cssElementRefSetter clipPathRef) + ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd) + ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart) + ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid) + ] + where + commaSeparate = + fmap (T.unpack . T.strip) . T.split (',' ==) . T.pack + +serializeDashArray :: [Number] -> String +serializeDashArray = + intercalate ", " . fmap serializeNumber + +instance XMLUpdatable DrawAttributes where + xmlTagName _ = "DRAWATTRIBUTES" + attributes = styleAttribute : fmap fst drawAttributesList + serializeTreeNode = genericSerializeNode + +styleAttribute :: SvgAttributeLens DrawAttributes +styleAttribute = SvgAttributeLens + { _attributeName = "style" + , _attributeUpdater = updater + , _attributeSerializer = const Nothing + } + where + updater attrs style = case parse styleString style of + Nothing -> attrs + Just decls -> foldl' applyer attrs decls + + cssUpdaters = [(T.pack $ _attributeName n, u) | (n, u) <- drawAttributesList] + applyer value (CssDeclaration txt elems) = + case lookup txt cssUpdaters of + Nothing -> value + Just f -> f value elems + +instance XMLUpdatable Rectangle where + xmlTagName _ = "rect" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["width" `parseIn` rectWidth + ,"height" `parseIn` rectHeight + ,"x" `parseIn` (rectUpperLeftCorner._1) + ,"y" `parseIn` (rectUpperLeftCorner._2) + ,"rx" `parseIn` (rectCornerRadius._1) + ,"ry" `parseIn` (rectCornerRadius._2) + ] + +instance XMLUpdatable Image where + xmlTagName _ = "image" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["width" `parseIn` imageWidth + ,"height" `parseIn` imageHeight + ,"x" `parseIn` (imageCornerUpperLeft._1) + ,"y" `parseIn` (imageCornerUpperLeft._2) + ,parserSetter "href" imageHref (Just . dropSharp) (Just . ('#':)) + ] + +instance XMLUpdatable Line where + xmlTagName _ = "line" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["x1" `parseIn` (linePoint1._1) + ,"y1" `parseIn` (linePoint1._2) + ,"x2" `parseIn` (linePoint2._1) + ,"y2" `parseIn` (linePoint2._2) + ] + +instance XMLUpdatable Ellipse where + xmlTagName _ = "ellipse" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["cx" `parseIn` (ellipseCenter._1) + ,"cy" `parseIn` (ellipseCenter._2) + ,"rx" `parseIn` ellipseXRadius + ,"ry" `parseIn` ellipseYRadius + ] + +instance XMLUpdatable Circle where + xmlTagName _ = "circle" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["cx" `parseIn` (circleCenter._1) + ,"cy" `parseIn` (circleCenter._2) + ,"r" `parseIn` circleRadius + ] + +instance XMLUpdatable Mask where + xmlTagName _ = "mask" + serializeTreeNode node = + updateWithAccessor _maskContent node $ + genericSerializeWithDrawAttr node + + attributes = + ["x" `parseIn` (maskPosition._1) + ,"y" `parseIn` (maskPosition._2) + ,"width" `parseIn` maskWidth + ,"height" `parseIn` maskHeight + ,"maskContentUnits" `parseIn` maskContentUnits + ,"maskUnits" `parseIn` maskUnits + ] + +instance XMLUpdatable ClipPath where + xmlTagName _ = "clipPath" + serializeTreeNode node = + updateWithAccessor _clipPathContent node $ + genericSerializeWithDrawAttr node + attributes = + ["clipPathUnits" `parseIn` clipPathUnits] + +instance XMLUpdatable Polygon where + xmlTagName _ = "polygon" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["points" `parseIn` polygonPoints] + +instance XMLUpdatable PolyLine where + xmlTagName _ = "polyline" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["points" `parseIn` polyLinePoints] + +instance XMLUpdatable Path where + xmlTagName _ = "path" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["d" `parseIn` pathDefinition] + +instance XMLUpdatable LinearGradient where + xmlTagName _ = "linearGradient" + serializeTreeNode node = + updateWithAccessor _linearGradientStops node $ genericSerializeNode node + + attributes = + ["gradientTransform" `parseIn` linearGradientTransform + ,"gradientUnits" `parseIn` linearGradientUnits + ,"spreadMethod" `parseIn` linearGradientSpread + ,"x1" `parseIn` (linearGradientStart._1) + ,"y1" `parseIn` (linearGradientStart._2) + ,"x2" `parseIn` (linearGradientStop._1) + ,"y2" `parseIn` (linearGradientStop._2) + ] + +instance XMLUpdatable Tree where + xmlTagName _ = "TREE" + attributes = [] + serializeTreeNode e = case e of + None -> X.blank_element + UseTree u _ -> serializeTreeNode u + GroupTree g -> serializeTreeNode g + SymbolTree s -> serializeTreeNode s + PathTree p -> serializeTreeNode p + CircleTree c -> serializeTreeNode c + PolyLineTree p -> serializeTreeNode p + PolygonTree p -> serializeTreeNode p + EllipseTree el -> serializeTreeNode el + LineTree l -> serializeTreeNode l + RectangleTree r -> serializeTreeNode r + TextTree Nothing t -> serializeTreeNode t + ImageTree i -> serializeTreeNode i + TextTree (Just p) t -> + setChildren textNode [X.Elem . setChildren pathNode $ X.elContent textNode] + where + textNode = serializeTreeNode t + pathNode = serializeTreeNode p + + +isNotNone :: Tree -> Bool +isNotNone None = False +isNotNone _ = True + +instance XMLUpdatable (Group Tree) where + xmlTagName _ = "g" + serializeTreeNode node = + updateWithAccessor (filter isNotNone . _groupChildren) node $ + genericSerializeWithDrawAttr node + attributes = [] + +instance XMLUpdatable (Symbol Tree) where + xmlTagName _ = "symbol" + serializeTreeNode node = + updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $ + genericSerializeWithDrawAttr node + attributes = + ["viewBox" `parseIn` (groupOfSymbol . groupViewBox)] + + +instance XMLUpdatable RadialGradient where + xmlTagName _ = "radialGradient" + serializeTreeNode node = + updateWithAccessor _radialGradientStops node $ genericSerializeNode node + attributes = + ["gradientTransform" `parseIn` radialGradientTransform + ,"gradientUnits" `parseIn` radialGradientUnits + ,"spreadMethod" `parseIn` radialGradientSpread + ,"cx" `parseIn` (radialGradientCenter._1) + ,"cy" `parseIn` (radialGradientCenter._2) + ,"r" `parseIn` radialGradientRadius + ,"fx" `parseIn` radialGradientFocusX + ,"fy" `parseIn` radialGradientFocusY + ] + +instance XMLUpdatable Use where + xmlTagName _ = "use" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["x" `parseIn` (useBase._1) + ,"y" `parseIn` (useBase._2) + ,"width" `parseIn` useWidth + ,"height" `parseIn` useHeight + ,parserSetter "href" useName (Just . dropSharp) (Just . ('#':)) + ] + +dropSharp :: String -> String +dropSharp ('#':rest) = rest +dropSharp a = a + +instance XMLUpdatable TextInfo where + xmlTagName _ = "tspan" + serializeTreeNode = genericSerializeNode + attributes = + [parserSetter "x" textInfoX (parse dashArray) dashNotEmpty + ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty + ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty + ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty + ,parserSetter "rotate" textInfoRotate + (parse numberList) + rotateNotEmpty + ,"textLength" `parseIn` textInfoLength + ] + where + dashNotEmpty [] = Nothing + dashNotEmpty lst = Just $ serializeDashArray lst + + rotateNotEmpty [] = Nothing + rotateNotEmpty lst = + Just . unwords $ printf "%g" <$> lst + + +instance XMLUpdatable TextPath where + xmlTagName _ = "textPath" + serializeTreeNode = genericSerializeNode + attributes = + ["startOffset" `parseIn` textPathStartOffset + ,"method" `parseIn` textPathMethod + ,"spacing" `parseIn` textPathSpacing + ,parserSetter "href" textPathName (Just . dropSharp) (Just . ('#':)) + ] + +instance XMLUpdatable Text where + xmlTagName _ = "text" + serializeTreeNode = serializeText + attributes = ["lengthAdjust" `parseIn` textAdjust] + + +instance XMLUpdatable Pattern where + xmlTagName _ = "pattern" + serializeTreeNode node = + updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node + attributes = + ["viewBox" `parseIn` patternViewBox + ,"patternUnits" `parseIn` patternUnit + ,"width" `parseIn` patternWidth + ,"height" `parseIn` patternHeight + ,"x" `parseIn` (patternPos._1) + ,"y" `parseIn` (patternPos._2) + ] + +instance XMLUpdatable Marker where + xmlTagName _ = "marker" + serializeTreeNode node = + updateWithAccessor _markerElements node $ genericSerializeWithDrawAttr node + attributes = + ["refX" `parseIn` (markerRefPoint._1) + ,"refY" `parseIn` (markerRefPoint._2) + ,"markerWidth" `parseIn` markerWidth + ,"markerHeight" `parseIn` markerHeight + ,"patternUnits" `parseIn` markerUnits + ,"orient" `parseIn` markerOrient + ,"viewBox" `parseIn` markerViewBox + ] + +serializeText :: Text -> X.Element +serializeText topText = topNode { X.elName = X.unqual "text" } where + topNode = serializeSpan $ _textRoot topText + + serializeSpan tspan = setChildren (mergeAttributes info drawInfo) subContent + where + info = genericSerializeNode $ _spanInfo tspan + drawInfo = genericSerializeNode $ _spanDrawAttributes tspan + subContent = serializeContent <$> _spanContent tspan + + serializeContent (SpanText t) = X.Text $ X.blank_cdata { X.cdData = T.unpack t } + serializeContent (SpanTextRef _t) = X.Text $ X.blank_cdata { X.cdData = "" } + serializeContent (SpanSub sub) = X.Elem $ serializeSpan sub + +unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath) +unparseText = extractResult . go True + where + extractResult (a, b, _) = (a, b) + + go startStrip [] = ([], Nothing, startStrip) + go startStrip (X.CRef _:rest) = go startStrip rest + go startStrip (X.Elem e@(nodeName -> "tspan"):rest) = + (SpanSub spans : trest, mpath, retStrip) + where + (trest, mpath, retStrip) = go restStrip rest + (sub, _, restStrip) = go startStrip $ X.elContent e + spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub + + go startStrip (X.Elem e@(nodeName -> "tref"):rest) = + case attributeFinder "href" e of + Nothing -> go startStrip rest + Just v -> (SpanTextRef v : trest, mpath, stripRet) + where (trest, mpath, stripRet) = go startStrip rest + + go startStrip (X.Elem e@(nodeName -> "textPath"):rest) = + case attributeFinder "href" e of + Nothing -> go startStrip rest + Just v -> (tsub ++ trest, pure p, retStrp) + where + p = (xmlUnparse e) { _textPathName = dropSharp v } + (trest, _, retStrp) = go restStrip rest + (tsub, _, restStrip) = go startStrip $ X.elContent e + + go startStrip (X.Elem _:rest) = go startStrip rest + go startStrip (X.Text t:rest) + | T.length cleanText == 0 = go startStrip rest + | otherwise = + (SpanText cleanText : trest, mpath, stripRet) + where + (trest, mpath, stripRet) = go subShouldStrip rest + + subShouldStrip = T.pack " " `T.isSuffixOf` cleanText + + space = T.singleton ' ' + singulariseSpaces tt + | space `T.isPrefixOf` tt = space + | otherwise = tt + + stripStart | startStrip = T.stripStart + | otherwise = id + + cleanText = stripStart + . T.concat + . fmap singulariseSpaces + . T.groupBy (\a b -> (a /= ' ' && b /= ' ') || a == b) + . T.filter (\c -> c /= '\n' && c /= '\r') + . T.map (\c -> if c == '\t' then ' ' else c) + . T.pack + $ X.cdData t + +gradientOffsetSetter :: SvgAttributeLens GradientStop +gradientOffsetSetter = SvgAttributeLens "offset" setter serialize + where + serialize a = Just $ printf "%d%%" percentage + where percentage = floor . (100 *) $ a ^. gradientOffset :: Int + + setter el str = el & gradientOffset .~ val + where + val = case parseMayStartDot complexNumber str of + Nothing -> 0 + Just (Num n) -> n + Just (Px n) -> n + Just (Percent n) -> n + Just (Em n) -> n + Just (Pc n) -> n + Just (Mm n) -> n + Just (Cm n) -> n + Just (Point n) -> n + Just (Inches n) -> n + +instance XMLUpdatable GradientStop where + xmlTagName _ = "stop" + serializeTreeNode = genericSerializeNode + attributes = + [gradientOffsetSetter + ,"stop-color" `parseIn` gradientColor + ] + + +data Symbols = Symbols + { symbols :: !(M.Map String Element) + , cssStyle :: [CssRule] + } + +emptyState :: Symbols +emptyState = Symbols mempty mempty + +parseGradientStops :: X.Element -> [GradientStop] +parseGradientStops = concatMap unStop . elChildren + where + unStop e@(nodeName -> "stop") = [xmlUnparse e] + unStop _ = [] + +withId :: X.Element -> (X.Element -> Element) + -> State Symbols Tree +withId el f = case attributeFinder "id" el of + Nothing -> return None + Just elemId -> do + modify $ \s -> + s { symbols = M.insert elemId (f el) $ symbols s } + return None + +unparseDefs :: X.Element -> State Symbols Tree +unparseDefs e@(nodeName -> "pattern") = do + subElements <- mapM unparse $ elChildren e + withId e . const . ElementPattern $ pat { _patternElements = subElements} + where + pat = xmlUnparse e +unparseDefs e@(nodeName -> "marker") = do + subElements <- mapM unparse $ elChildren e + withId e . const . ElementMarker $ mark {_markerElements = subElements } + where + mark = xmlUnparseWithDrawAttr e +unparseDefs e@(nodeName -> "mask") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + parsedMask = xmlUnparseWithDrawAttr e + withId e . const . ElementMask $ parsedMask { _maskContent = realChildren } + +unparseDefs e@(nodeName -> "clipPath") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + parsedClip = xmlUnparseWithDrawAttr e + withId e . const . ElementClipPath $ parsedClip { _clipPathContent = realChildren } + +unparseDefs e@(nodeName -> "linearGradient") = + withId e $ ElementLinearGradient . unparser + where + unparser ee = + xmlUnparse ee & linearGradientStops .~ parseGradientStops ee +unparseDefs e@(nodeName -> "radialGradient") = + withId e $ ElementRadialGradient . unparser + where + unparser ee = + xmlUnparse ee & radialGradientStops .~ parseGradientStops ee +unparseDefs e = do + el <- unparse e + withId e (const $ ElementGeometry el) + +unparse :: X.Element -> State Symbols Tree +unparse e@(nodeName -> "style") = do + case parseOnly (many1 ruleSet) . T.pack $ strContent e of + Left _ -> return () + Right rules -> + modify $ \s -> s { cssStyle = cssStyle s ++ rules } + return None +unparse e@(nodeName -> "defs") = do + mapM_ unparseDefs $ elChildren e + return None +unparse e@(nodeName -> "symbol") = do + symbolChildren <- mapM unparse $ elChildren e + let realChildren = filter isNotNone symbolChildren + pure . SymbolTree . Symbol $ groupNode & groupChildren .~ realChildren + where + groupNode :: Group Tree + groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e + +unparse e@(nodeName -> "g") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + + groupNode :: Group Tree + groupNode = xmlUnparseWithDrawAttr e + + pure $ GroupTree $ groupNode & groupChildren .~ realChildren + +unparse e@(nodeName -> "text") = do + pathWithGeometry <- pathGeomtryOf tPath + pure . TextTree pathWithGeometry $ xmlUnparse e & textRoot .~ root + where + (textContent, tPath) = unparseText $ X.elContent e + + pathGeomtryOf Nothing = pure Nothing + pathGeomtryOf (Just pathInfo) = do + pathElem <- gets $ M.lookup (_textPathName pathInfo) . symbols + case pathElem of + Nothing -> pure Nothing + Just (ElementLinearGradient _) -> pure Nothing + Just (ElementRadialGradient _) -> pure Nothing + Just (ElementPattern _) -> pure Nothing + Just (ElementMask _) -> pure Nothing + Just (ElementClipPath _) -> pure Nothing + Just (ElementMarker _) -> pure Nothing + Just (ElementGeometry (PathTree p)) -> + pure . Just $ pathInfo { _textPathData = _pathDefinition p } + Just (ElementGeometry _) -> pure Nothing + + root = TextSpan + { _spanInfo = xmlUnparse e + , _spanDrawAttributes = xmlUnparse e + , _spanContent = textContent + } + +unparse e = pure $ case nodeName e of + "image" -> ImageTree parsed + "ellipse" -> EllipseTree parsed + "rect" -> RectangleTree parsed + "polyline" -> PolyLineTree parsed + "polygon" -> PolygonTree parsed + "circle"-> CircleTree parsed + "line" -> LineTree parsed + "path" -> PathTree parsed + "use" -> UseTree parsed Nothing + _ -> None + where + parsed :: (XMLUpdatable a, WithDrawAttributes a) => a + parsed = xmlUnparseWithDrawAttr e + +unparseDocument :: FilePath -> X.Element -> Maybe Document +unparseDocument rootLocation e@(nodeName -> "svg") = Just Document + { _viewBox = + attributeFinder "viewBox" e >>= parse viewBoxParser + , _elements = parsedElements + , _width = lengthFind "width" + , _height = lengthFind "height" + , _definitions = symbols named + , _description = "" + , _styleRules = cssStyle named + , _documentLocation = rootLocation + } + where + (parsedElements, named) = + runState (mapM unparse $ elChildren e) emptyState + lengthFind n = + attributeFinder n e >>= parse complexNumber +unparseDocument _ _ = Nothing + +-- | Transform a SVG document to a XML node. +xmlOfDocument :: Document -> X.Element +xmlOfDocument doc = + X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ defsTag ++ children) + where + attr name = X.Attr (X.unqual name) + children = [serializeTreeNode el | el <- _elements doc, isNotNone el ] + + defsTag | null defs = [] + | otherwise = [X.node (X.unqual "defs") defs] + + defs = [elementRender k e | (k, e) <- M.assocs $ _definitions doc + , isElementNotNone e] + + isElementNotNone (ElementGeometry el) = isNotNone el + isElementNotNone _ = True + + elementRender k e = case e of + ElementGeometry t -> serializeTreeNode t + ElementMarker m -> serializeTreeNode m + ElementMask m -> serializeTreeNode m + ElementClipPath c -> serializeTreeNode c + ElementPattern p -> + X.add_attr (attr "id" k) $ serializeTreeNode p + ElementLinearGradient lg -> + X.add_attr (attr "id" k) $ serializeTreeNode lg + ElementRadialGradient rg -> + X.add_attr (attr "id" k) $ serializeTreeNode rg + + docViewBox = case _viewBox doc of + Nothing -> [] + Just b -> [attr "viewBox" $ serializeViewBox b] + + descTag = case _description doc of + "" -> [] + txt -> [X.node (X.unqual "desc") txt] + + styleTag = case _styleRules doc of + [] -> [] + rules -> [X.node (X.unqual "style") + ([attr "type" "text/css"], txt)] + where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules + + attrs = + docViewBox ++ + [attr "xmlns" "http://www.w3.org/2000/svg" + ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink" + ,attr "version" "1.1"] ++ + catMaybes [attr "width" . serializeNumber <$> _width doc + ,attr "height" . serializeNumber <$> _height doc + ] +
+ svg-tree.cabal view
@@ -0,0 +1,62 @@+name: svg-tree +version: 0.1 +synopsis: SVG file loader and serializer +description: + svg-tree provides types representing a SVG document, + and allows to load and save it. + . + The types definition are aimed at rendering, + so they are rather comple. For simpler SVG document building, + look after `lucid-svg`. + . + To render an svg document you can use the `rasterific-svg` package + + +license: BSD3 +author: Vincent Berthoux +maintainer: Vincent Berthoux +-- copyright: +category: Graphics, Svg +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: changelog + +Source-Repository head + Type: git + Location: git://github.com/Twinside/svg-tree.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/svg-tree.git + Tag: v0.1 + +library + hs-source-dirs: src + Ghc-options: -O3 -Wall + ghc-prof-options: -rtsopts -Wall -prof -auto-all + default-language: Haskell2010 + exposed-modules: Graphics.Svg + , Graphics.Svg.CssTypes + , Graphics.Svg.Types + + other-modules: Graphics.Svg.NamedColors + , Graphics.Svg.XmlParser + , Graphics.Svg.PathParser + , Graphics.Svg.CssParser + , Graphics.Svg.ColorParser + + build-depends: base >= 4.6 && < 4.9 + , JuicyPixels >= 3.2 + , attoparsec >= 0.12 + , scientific >= 0.3 + , containers >= 0.5 + , xml >= 1.3 + , bytestring >= 0.10 + , linear >= 1.16 + , transformers >= 0.4 + , vector >= 0.10 + , text >= 1.2 + , mtl >= 2.2 + , lens >= 4.7 +