diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Vincent Berthoux + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Vincent Berthoux nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,95 @@ +-*-change-log-*- + +v0.7.0.0 March 2019 + + * fork from svg-tree due to 'reanimate' requiring breaking changes + * Fix: change x,y rect defaults from '0' to 'auto'. + * Expose list of named svg colors. + * Adding: Allow definitions to appear anywhere in an svg document. + * Change module namespace from Graphics.Svg to Graphics.SvgTree + +v0.6.2.3 October 2018 + + * GHC 8.6 fixes + * Adding: Allow definitions to appear anywhere in an svg document. + +v0.6.2.2 December 2017 + + * Adding `Semigroup` instances for defined `Monoid`, for GHC 8.4 + +v0.6.2.1 December 2017 + * Workaround/Fix: removed reliance on Template Haskell to derive lenses, + by writing them directly in the file, using the ddump-splices. For some + reason Haddock associated with GHC 8.2.2 was entering infinite loop on + the Types file. Ugly workaround, but at least it works. + +v0.6.2 August 2017 + * Fix: gather named elements even outside of tags. + * Fix: URL ID now can contain more characters. + +v0.6.1: January 2017 + * Fix: some gradient mesh parsing, stop can have style (like with Inkscape 0.92) + * Fix: norm say "" is the global tag + * Fix: Adding `xlink:href` attribute on patterns + * Fix: Adding `patternTransform` attribute on patterns + +v0.6: September 2016 + * Add SVG 2.0 gradient mesh + +v0.5.1.2: September 2016 + * Fix path parsing with white space prefix + +v0.5.1.1: May 2016 + * Fix: GHC 8.0 compatibility + +v0.5.1: March 2016 + * Fix: serialization of multi criteria css selector. + +v0.5: March 2016: + * Adding: preserveAspectRatio attribute + * Fix: Application of CSS rules with indirect parent/child relation. + +v0.4.2: March 2016 + * Enhancement: avoiding serializatinon of empty class attribute + * Fix: incorrect deserialization of complex CSS + * Fix: Really fixing duplicate ID with serialization + +v0.4.1: February 2016 + * Fix: fixing duplicate ID with serialization + +v0.4: February 2016 + * Breaking change: viewbox types are no longer Int + but double, sneakingly passed in v0.3.2.2. This + version acknoweledge this change + +V0.3.2.2 February 2016 (Deprecated) + * Fix: Bad serialization of some None constructors. + +v0.3.2.1 October 2015 + * Fix: Don't add '#' for serialization + +v0.3.2 August 2015 + * Fix: allow compilation with GHC 7.4 + +v0.3.1 May 2015 + * Fix: Bumping lens dependency and removing upper bound. + +v0.3 April 2015 + * Breaking change: Switching all the numeric types associated to geometry + to Double precision (thx to Kasbah) + +v0.2 April 2015 + * Fix: Differentiating opacity & fill-opacity, as they are + semantically deferent (BREAKING CHANGE!) + +v0.1.1 April 2015 + * Fix: Bumping lens bounds + +v0.1.0.2 March 2015 + * Fix: Bumping lens bounds + +v0.1.0.1 + * Fix: Lowering some lower bounds + +v0.1 + * Initial release diff --git a/reanimate-svg.cabal b/reanimate-svg.cabal new file mode 100644 --- /dev/null +++ b/reanimate-svg.cabal @@ -0,0 +1,74 @@ +name: reanimate-svg +version: 0.7.0.0 +synopsis: SVG file loader and serializer +description: + reanimate-svg 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`. + + +license: BSD3 +license-file: LICENSE +author: Vincent Berthoux, David Himmelstrup +maintainer: David Himmelstrup +-- copyright: +category: Graphics, Svg +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: changelog.md + +Source-Repository head + Type: git + Location: git://github.com/lemmih/reanimate-svg.git + +library + hs-source-dirs: src + Ghc-options: -O3 -Wall + default-language: Haskell2010 + exposed-modules: Graphics.SvgTree + , Graphics.SvgTree.CssTypes + , Graphics.SvgTree.Types + , Graphics.SvgTree.PathParser + , Graphics.SvgTree.NamedColors + + other-modules: Graphics.SvgTree.XmlParser + , Graphics.SvgTree.CssParser + , Graphics.SvgTree.ColorParser + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + else + -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 + build-depends: fail == 4.9.*, semigroups == 0.18.* + + build-depends: base >= 4.5 && < 6 + , JuicyPixels >= 3.2 + , attoparsec >= 0.12 + , scientific >= 0.3 + , containers >= 0.4 + , xml >= 1.3 + , bytestring >= 0.10 + , linear >= 1.20 + , vector >= 0.10 + , text >= 1.1 + , transformers >= 0.3 && < 0.6 + , mtl >= 2.1 && < 2.3 + , lens >= 4.6 && < 5 + +test-suite test + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + type: exitcode-stdio-1.0 + build-depends: base + , svg-tree + , attoparsec >= 0.12 + , scientific >= 0.3 + , linear >= 1.20 + , hspec + ghc-options: -Wall -threaded + other-modules: PathParserSpec diff --git a/src/Graphics/SvgTree.hs b/src/Graphics/SvgTree.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +-- | Module providing basic input/output for the SVG document, +-- for document building, please refer to Graphics.Svg.Types. +module Graphics.SvgTree + ( -- * Saving/Loading functions + loadSvgFile + , parseSvgFile + , xmlOfDocument + , saveXmlFile + + -- * Manipulation functions + , cssApply + , cssRulesOfText + , applyCSSRules + , resolveUses + + -- * Type definitions + , module Graphics.SvgTree.Types + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +import Control.Lens +import qualified Data.ByteString as B +import Data.List (foldl') +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 Graphics.SvgTree.CssParser (cssRulesOfText) +import Graphics.SvgTree.CssTypes +import Graphics.SvgTree.Types +import Graphics.SvgTree.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 = M.lookup (_useName nfo) $ _definitions doc + +-- | Rewrite the document by applying the CSS rules embedded +-- inside it. +applyCSSRules :: Document -> Document +applyCSSRules doc = doc + { _elements = cssApply (_styleRules doc) <$> _elements doc } diff --git a/src/Graphics/SvgTree/ColorParser.hs b/src/Graphics/SvgTree/ColorParser.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/ColorParser.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.SvgTree.ColorParser + ( colorParser + , colorSerializer + , textureParser + , textureSerializer + , urlRef + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((*>), (<$), (<$>), (<*), (<*>)) +#endif + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser, char, digit, inClass, letter, + many1, option, satisfy, scientific, + skipSpace, string, takeWhile1) +import Data.Bits (unsafeShiftL, (.|.)) + +import Codec.Picture (PixelRGBA8 (..)) +import qualified Data.Map as M +import Data.Scientific (toRealFloat) +import Data.Word (Word8) +import Graphics.SvgTree.NamedColors +import Graphics.SvgTree.Types +import Text.Printf (printf) + +commaWsp :: Parser () +commaWsp = skipSpace *> option () (string "," *> return ()) + <* skipSpace + + +num :: Parser Double +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber :: Parser Double + doubleNumber = toRealFloat <$> scientific + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + +colorSerializer :: PixelRGBA8 -> String +colorSerializer (PixelRGBA8 r g b _) = printf "#%02X%02X%02X" r g b + +colorParser :: Parser PixelRGBA8 +colorParser = rgbColor + <|> (string "#" *> (color <|> colorReduced)) + <|> namedColor + where + charRange c1 c2 = + (\c -> fromIntegral $ fromEnum c - fromEnum c1) <$> satisfy (\v -> c1 <= v && v <= c2) + black = PixelRGBA8 0 0 0 255 + + hexChar :: Parser Word8 + hexChar = charRange '0' '9' + <|> ((+ 10) <$> charRange 'a' 'f') + <|> ((+ 10) <$> charRange 'A' 'F') + + namedColor = do + str <- takeWhile1 (inClass "a-z") + return $ M.findWithDefault black str svgNamedColors + + percentToWord v = floor $ v * (255 / 100) + + numPercent = ((percentToWord <$> num) <* string "%") + <|> (floor <$> num) + + hexByte = (\h1 h2 -> h1 `unsafeShiftL` 4 .|. h2) + <$> hexChar <*> hexChar + + color = (\r g b -> PixelRGBA8 r g b 255) + <$> hexByte <*> hexByte <*> hexByte + rgbColor = (\r g b -> PixelRGBA8 r g b 255) + <$> (string "rgb(" *> numPercent) + <*> (commaWsp *> numPercent) + <*> (commaWsp *> numPercent <* skipSpace <* string ")") + + colorReduced = + (\r g b -> PixelRGBA8 (r * 17) (g * 17) (b * 17) 255) + <$> hexChar <*> hexChar <*> hexChar + + +textureSerializer :: Texture -> String +textureSerializer (ColorRef px) = colorSerializer px +textureSerializer (TextureRef str) = printf "url(#%s)" str +textureSerializer FillNone = "none" + +urlRef :: Parser String +urlRef = string "url(" *> skipSpace *> + char '#' *> many1 (letter <|> digit <|> char '_' <|> char '.' <|> char '-' <|> char ':') + <* skipSpace <* char ')' <* skipSpace + + +textureParser :: Parser Texture +textureParser = + none <|> (TextureRef <$> urlRef) + <|> (ColorRef <$> colorParser) + where + none = FillNone <$ string "none" diff --git a/src/Graphics/SvgTree/CssParser.hs b/src/Graphics/SvgTree/CssParser.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/CssParser.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +module Graphics.SvgTree.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, char, digit, double, + letter, notChar, parseOnly, sepBy1, + skipMany, skipSpace, string, ()) +import qualified Data.Attoparsec.Text as AT + +import Data.Attoparsec.Combinator (many1, option, sepBy) + +import Codec.Picture (PixelRGBA8 (..)) +import qualified Data.Map as M +import qualified Data.Text as T +import Graphics.SvgTree.ColorParser (colorParser) +import Graphics.SvgTree.CssTypes +import Graphics.SvgTree.NamedColors (svgNamedColors) + +num :: Parser Double +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber = char '.' *> (scale <$> double) + <|> double + + scalingCoeff n = 10 ^ digitCount + where digitCount :: Int + digitCount = ceiling . logBase 10 $ abs n + + scale n = n / scalingCoeff n + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + + +ident :: Parser T.Text +ident = + (\f c -> f . T.cons c . T.pack) + <$> trailingSub + <*> nmstart <*> nmchar + where + trailingSub = option id $ T.cons '-' <$ char '-' + underscore = char '_' + nmstart = letter <|> underscore + nmchar = many (letter <|> digit <|> underscore <|> char '-') + +str :: Parser T.Text +str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace + "str" + +between :: Char -> Char -> Parser a -> Parser a +between o e p = + (skipSpace *> + char o *> skipSpace *> p + <* skipSpace <* char e <* skipSpace) + ("between " ++ [o, e]) + +bracket :: Parser a -> Parser a +bracket = between '[' ']' + + +comment :: Parser () +comment = string "/*" *> toStar *> skipSpace + where + toStar = skipMany (notChar '*') *> char '*' *> testEnd + testEnd = (() <$ char '/') <|> toStar + +cleanSpace :: Parser () +cleanSpace = skipSpace <* many comment + +-- | combinator: '+' S* | '>' S* +combinator :: Parser CssSelector +combinator = parse <* cleanSpace where + parse = Nearby <$ char '+' + <|> DirectChildren <$ char '>' + "combinator" + +-- unary_operator : '-' | '+' ; + +commaWsp :: Parser Char +commaWsp = skipSpace *> option ',' (char ',') <* skipSpace + +ruleSet :: Parser CssRule +ruleSet = cleanSpace *> rule where + rule = CssRule + <$> selector `sepBy1` commaWsp + <*> (between '{' '}' styleString) + "cssrule" + +styleString :: Parser [CssDeclaration] +styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp + "styleString" + where semiWsp = skipSpace *> char ';' <* skipSpace + mayWsp = option ';' semiWsp + +selector :: Parser [CssSelector] +selector = (:) + <$> (AllOf <$> simpleSelector <* skipSpace "firstpart:(") + <*> ((next <|> return []) "secondpart") + "selector" + where + combOpt :: Parser ([CssSelector] -> [CssSelector]) + + combOpt = cleanSpace *> option id ((:) <$> combinator) + next :: Parser [CssSelector] + next = id <$> combOpt <*> selector + +simpleSelector :: Parser [CssDescriptor] +simpleSelector = (:) <$> elementName <*> many whole + <|> (many1 whole "inmany") + "simple selector" + where + whole = pseudo <|> hash <|> classParser <|> attrib + "whole" + pseudo = char ':' *> (OfPseudoClass <$> ident) + "pseudo" + hash = char '#' *> (OfId <$> ident) + "hash" + classParser = char '.' *> (OfClass <$> ident) + "classParser" + + elementName = el <* skipSpace "elementName" + where el = (OfName <$> ident) + <|> AnyElem <$ char '*' + + attrib = bracket + (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str)) + "attrib") + +declaration :: Parser CssDeclaration +declaration = + CssDeclaration <$> property + <*> (char ':' + *> cleanSpace + *> many1 expr + <* prio + ) + "declaration" + where + property = (ident <* cleanSpace) "property" + prio = option "" $ string "!important" + +operator :: Parser CssElement +operator = skipSpace *> op <* skipSpace + where + op = CssOpSlash <$ char '/' + <|> CssOpComa <$ char ',' + "operator" + +expr :: Parser [CssElement] +expr = ((:) <$> term <*> (concat <$> many termOp)) + "expr" + where + op = option (:[]) $ (\a b -> [a, b]) <$> operator + termOp = ($) <$> op <*> term + +dashArray :: Parser [Number] +dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp) + +numberList :: Parser [Double] +numberList = skipSpace *> (num `sepBy1` commaWsp) + +complexNumber :: Parser Number +complexNumber = do + n <- num + (Percent (n / 100) <$ char '%') + <|> (Em n <$ string "em") + <|> (Mm n <$ string "mm") + <|> (Cm n <$ string "cm") + <|> (Point n <$ string "pt") + <|> (Pc n <$ string "pc") + <|> (Px n <$ string "px") + <|> (Inches n <$ string "in") + <|> pure (Num n) + +term :: Parser CssElement +term = checkRgb <$> function + <|> (CssNumber <$> complexNumber) + <|> (CssString <$> str) + <|> (checkNamedColor <$> ident) + <|> (CssColor <$> colorParser) + where + comma = skipSpace *> char ',' <* skipSpace + checkNamedColor n + | Just c <- M.lookup n svgNamedColors = CssColor c + | otherwise = CssIdent n + + ref = char '#' *> ident + + checkRgb (CssFunction "rgb" + [CssNumber r, CssNumber g, CssNumber b]) = + CssColor $ PixelRGBA8 (to r) (to g) (to b) 255 + where clamp = max 0 . min 255 + to (Num n) = floor $ clamp n + to (Px n) = floor $ clamp n + to (Percent p) = floor . clamp $ p * 255 + to (Em c) = floor $ clamp c + to (Pc n) = floor $ clamp n + to (Mm n) = floor $ clamp n + to (Cm n) = floor $ clamp n + to (Point n) = floor $ clamp n + to (Inches n) = floor $ clamp n + + checkRgb a = a + functionParam = (CssReference <$> ref) <|> term + + function = CssFunction + <$> ident <* char '(' + <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace + +-- | Parse CSS text into rules. +cssRulesOfText :: T.Text -> [CssRule] +cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of + Left _ -> [] + Right rules -> rules diff --git a/src/Graphics/SvgTree/CssTypes.hs b/src/Graphics/SvgTree/CssTypes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/CssTypes.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Define the types used to describes CSS elements +module Graphics.SvgTree.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.List (intersperse) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as TB +import Text.Printf + +import Codec.Picture (PixelRGBA8 (..)) + +-- | Alias describing a "dot per inch" information +-- used for size calculation (see toUserUnit). +type Dpi = Int + +-- | Helper typeclass for serialization to Text. +class TextBuildable a where + -- | Serialize an element to a text builder. + tserialize :: a -> TB.Builder + +-- | Describe an element of a CSS selector. Multiple +-- elements can be combined in a CssSelector type. +data CssDescriptor + = OfClass T.Text -- ^ .IDENT + | OfName T.Text -- ^ IDENT + | OfId T.Text -- ^ #IDENT + | OfPseudoClass T.Text -- ^ `:IDENT` (ignore function syntax) + | AnyElem -- ^ '*' + | WithAttrib T.Text T.Text -- ^ `` + deriving (Eq, Show) + +instance TextBuildable CssDescriptor where + tserialize d = case d of + OfClass c -> si '.' <> ft c + OfName n -> ft n + OfId i -> si '#' <> ft i + OfPseudoClass c -> si '#' <> ft c + AnyElem -> si '*' + WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']'] + where + ft = TB.fromText + si = TB.singleton + +-- | Define complex selector. +data CssSelector + = Nearby -- ^ Correspond to the `+` CSS selector. + | DirectChildren -- ^ Correspond to the `>` CSS selectro. + | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements + -- of the list must be matched. + deriving (Eq, Show) + +instance TextBuildable CssSelector where + tserialize s = case s of + Nearby -> si '+' + DirectChildren -> si '>' + AllOf lst -> mconcat $ map tserialize lst + where + si = TB.singleton + +-- | A CssSelectorRule is a list of all the elements +-- that must be meet in a depth first search fashion. +type CssSelectorRule = [CssSelector] + +-- | Represent a CSS selector and the different declarations +-- to apply to the matched elemens. +data CssRule = CssRule + { -- | At the first level represent a list of elements + -- to be matched. If any match is made, you can apply + -- the declarations. At the second level + cssRuleSelector :: ![CssSelectorRule] + -- | Declarations to apply to the matched element. + , cssDeclarations :: ![CssDeclaration] + } + deriving (Eq, Show) + +instance TextBuildable CssRule where + tserialize (CssRule selectors decl) = + mconcat tselectors + <> ft " {\n" + <> mconcat (fmap tserializeDecl decl) + <> ft "}\n" + where + ft = TB.fromText + tserializeDecl d = ft " " <> tserialize d <> ft ";\n" + tselector = + mconcat . intersperse (ft " ") . fmap tserialize + tselectors = + intersperse (ft ",\n") $ fmap tselector selectors + +-- | Interface for elements to be matched against +-- some CssRule. +class CssMatcheable a where + -- | For an element, tell its optional ID attribute. + cssIdOf :: a -> Maybe T.Text + -- | For an element, return all of it's class attributes. + cssClassOf :: a -> [T.Text] + -- | Return the name of the tagname of the element + cssNameOf :: a -> T.Text + -- | Return a value of a given attribute if present + cssAttribOf :: a -> T.Text -> Maybe T.Text + +-- | Represent a zipper in depth at the first list +-- level, and the previous nodes at in the second +-- list level. +type CssContext a = [[a]] + +isDescribedBy :: CssMatcheable a + => a -> [CssDescriptor] -> Bool +isDescribedBy e = all tryMatch + where + tryMatch (OfClass t) = t `elem` cssClassOf e + tryMatch (OfId i) = cssIdOf e == Just i + tryMatch (OfName n) = cssNameOf e == n + tryMatch (OfPseudoClass _) = False + tryMatch (WithAttrib a v) = cssAttribOf e a == Just v + tryMatch AnyElem = True + +isMatching :: CssMatcheable a + => CssContext a -> [CssSelector] -> Bool +isMatching = go where + go _ [] = True + go [] _ = False + go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest + go ((e:_):upper) (DirectChildren:AllOf descr:rest) + | isDescribedBy e descr = go upper rest + go _ (DirectChildren:_) = False + go ((e:_):upper) selectors@(AllOf descr : rest) + | isDescribedBy e descr = go upper rest + | otherwise = go upper selectors + go (_:upper) selector = go upper selector + +-- | Given CSS rules, find all the declaration to apply to the +-- element in a given context. +findMatchingDeclarations :: CssMatcheable a + => [CssRule] -> CssContext a -> [CssDeclaration] +findMatchingDeclarations rules context = + concat [cssDeclarations rule + | rule <- rules + , selector <- cssRuleSelector rule + , isMatching context $ reverse selector ] + +-- | Represent the content to apply to some +-- CSS matched rules. +data CssDeclaration = CssDeclaration + { -- | Property name to change (like font-family or color). + _cssDeclarationProperty :: T.Text + -- | List of values + , _cssDecarationlValues :: [[CssElement]] + } + deriving (Eq, Show) + +instance TextBuildable CssDeclaration where + tserialize (CssDeclaration n elems) = + mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems + where + finalElems = map tserialize (concat elems) + ft = TB.fromText + si = TB.singleton + + +-- | Encode complex number possibly dependant to the current +-- render size. +data Number + = Num Double -- ^ Simple coordinate in current user coordinate. + | Px Double -- ^ With suffix "px" + | Em Double -- ^ Number relative to the current font size. + | Percent Double -- ^ Number relative to the current viewport size. + | Pc Double + | Mm Double -- ^ Number in millimeters, relative to DPI. + | Cm Double -- ^ Number in centimeters, relative to DPI. + | Point Double -- ^ Number in points, relative to DPI. + | Inches Double -- ^ Number in inches, relative to DPI. + deriving (Eq, Show) + +-- | Helper function to modify inner value of a number +mapNumber :: (Double -> Double) -> Number -> Number +mapNumber f nu = case nu of + Num n -> Num $ f n + Px n -> Px $ f n + Em n -> Em $ f n + Percent n -> Percent $ f n + Pc n -> Pc $ f n + Mm n -> Mm $ f n + Cm n -> Cm $ f n + Point n -> Point $ f n + Inches n -> Inches $ f n + +-- | Encode the number to string which can be used in a +-- CSS or a svg attributes. +serializeNumber :: Number -> String +serializeNumber n = case n of + Num c -> printf "%g" c + Px c -> printf "%gpx" c + Em cc -> printf "%gem" cc + Percent p -> printf "%d%%" (floor $ 100 * p :: Int) + Pc p -> printf "%gpc" p + Mm m -> printf "%gmm" m + Cm c -> printf "%gcm" c + Point p -> printf "%gpt" p + Inches i -> printf "%gin" i + +instance TextBuildable Number where + tserialize = TB.fromText . T.pack . serializeNumber + +-- | Value of a CSS property. +data CssElement + = CssIdent !T.Text + | CssString !T.Text + | CssReference !T.Text + | CssNumber !Number + | CssColor !PixelRGBA8 + | CssFunction !T.Text ![CssElement] + | CssOpComa + | CssOpSlash + deriving (Eq, Show) + +instance TextBuildable CssElement where + tserialize e = case e of + CssIdent n -> ft n + CssString s -> si '"' <> ft s <> si '"' + CssReference r -> si '#' <> ft r + CssNumber n -> tserialize n + CssColor (PixelRGBA8 r g b _) -> + ft . T.pack $ printf "#%02X%02X%02X" r g b + CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')'] + where args = intersperse (ft ", ") (map tserialize els) + CssOpComa -> si ',' + CssOpSlash -> si '/' + where + ft = TB.fromText + si = TB.singleton + +-- | This function replace all device dependant units to user +-- units given it's DPI configuration. +-- Preserve percentage and "em" notation. +toUserUnit :: Dpi -> Number -> Number +toUserUnit dpi = go where + go nu = case nu of + Num _ -> nu + Px p -> go $ Num p + Em _ -> nu + Percent _ -> nu + Pc n -> go . Inches $ (12 * n) / 72 + Inches n -> Num $ n * fromIntegral dpi + Mm n -> go . Inches $ n / 25.4 + Cm n -> go . Inches $ n / 2.54 + Point n -> go . Inches $ n / 72 diff --git a/src/Graphics/SvgTree/NamedColors.hs b/src/Graphics/SvgTree/NamedColors.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/NamedColors.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +module Graphics.SvgTree.NamedColors( svgNamedColors ) where + +import Codec.Picture (PixelRGBA8 (..)) +import qualified Data.Map as M +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) + ] diff --git a/src/Graphics/SvgTree/PathParser.hs b/src/Graphics/SvgTree/PathParser.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/PathParser.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Graphics.SvgTree.PathParser + ( transformParser + , command + , pathParser + , viewBoxParser + , pointData + , gradientCommand + , serializePoints + , serializeCommand + , serializeGradientCommand + , serializeCommands + , serializeViewBox + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((*>), (<$), (<$>), (<*), (<*>)) +#endif + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Combinator (option, sepBy, sepBy1) +import Data.Attoparsec.Text (Parser, char, digit, many1, + parseOnly, scientific, skipSpace, + string) +import Data.Scientific (toRealFloat) + +import qualified Data.Text as T +import Graphics.SvgTree.Types +import Linear hiding (angle, point) +import Text.Printf (printf) + +num :: Parser Double +num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) + where doubleNumber :: Parser Double + doubleNumber = toRealFloat <$> scientific <|> shorthand + + plusMinus = negate <$ string "-" <*> doubleNumber + <|> string "+" *> doubleNumber + <|> doubleNumber + + shorthand = process' <$> (string "." *> many1 digit) + process' = either (const 0) id . parseOnly doubleNumber . T.pack . (++) "0." + +viewBoxParser :: Parser (Double, Double, Double, Double) +viewBoxParser = (,,,) + <$> iParse <*> iParse <*> iParse <*> iParse + where + iParse = num <* skipSpace + +serializeViewBox :: (Double, Double, Double, Double) -> String +serializeViewBox (a, b, c, d) = printf "%g %g %g %g" a b c d + +commaWsp :: Parser () +commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace + +point :: Parser RPoint +point = V2 <$> num <* commaWsp <*> num + +pointData :: Parser [RPoint] +pointData = point `sepBy` commaWsp + +pathParser :: Parser [PathCommand] +pathParser = skipSpace *> many1 command + +command :: Parser PathCommand +command = (MoveTo OriginAbsolute <$ string "M" <*> pointList) + <|> (MoveTo OriginRelative <$ string "m" <*> pointList) + <|> (LineTo OriginAbsolute <$ string "L" <*> pointList) + <|> (LineTo OriginRelative <$ string "l" <*> pointList) + <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList) + <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList) + <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList) + <|> (VerticalTo OriginRelative <$ string "v" <*> coordList) + <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs) + <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs) + <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList) + <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList) + <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList) + <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList) + <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList) + <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList) + <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs) + <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs) + <|> (EndPath <$ string "Z" <* commaWsp) + <|> (EndPath <$ string "z" <* commaWsp) + where pointList = point `sepBy1` commaWsp + pointPair = (,) <$> point <* commaWsp <*> point + pointPairList = pointPair `sepBy1` commaWsp + coordList = num `sepBy1` commaWsp + curveToArgs = (,,) <$> (point <* commaWsp) + <*> (point <* commaWsp) + <*> point + manyComma a = a `sepBy1` commaWsp + + numComma = num <* commaWsp + ellipticalArgs = (,,,,,) <$> numComma + <*> numComma + <*> numComma + <*> (fmap (/= 0) numComma) + <*> (fmap (/= 0) numComma) + <*> point + +serializePoint :: RPoint -> String +serializePoint (V2 x y) = printf "%g,%g" x y + +serializePoints :: [RPoint] -> String +serializePoints = unwords . fmap serializePoint + +serializeCoords :: [Coord] -> String +serializeCoords = unwords . fmap (printf "%g") + +serializePointPair :: (RPoint, RPoint) -> String +serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b + +serializePointPairs :: [(RPoint, RPoint)] -> String +serializePointPairs = unwords . fmap serializePointPair + +serializePointTriplet :: (RPoint, RPoint, RPoint) -> String +serializePointTriplet (a, b, c) = + serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c + +serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String +serializePointTriplets = unwords . fmap serializePointTriplet + +serializeCommands :: [PathCommand] -> String +serializeCommands = unwords . fmap serializeCommand + +serializeCommand :: PathCommand -> String +serializeCommand p = case p of + MoveTo OriginAbsolute points -> "M" ++ serializePoints points + MoveTo OriginRelative points -> "m" ++ serializePoints points + LineTo OriginAbsolute points -> "L" ++ serializePoints points + LineTo OriginRelative points -> "l" ++ serializePoints points + + HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords + HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords + VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords + VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords + + CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets + CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets + SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs + SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs + QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs + QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs + SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points + SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points + EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args + EllipticalArc OriginRelative args -> "a" ++ serializeArgs args + EndPath -> "Z" + where + serializeArg (a, b, c, d, e, V2 x y) = + printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y + serializeArgs = unwords . fmap serializeArg + + + +transformParser :: Parser Transformation +transformParser = matrixParser + <|> translationParser + <|> scaleParser + <|> rotateParser + <|> skewYParser + <|> skewXParser + +functionParser :: T.Text -> Parser [Double] +functionParser funcName = + string funcName *> skipSpace + *> char '(' *> skipSpace + *> num `sepBy1` commaWsp + <* skipSpace <* char ')' <* skipSpace + +translationParser :: Parser Transformation +translationParser = do + args <- functionParser "translate" + return $ case args of + [x] -> Translate x 0 + [x, y] -> Translate x y + _ -> TransformUnknown + +skewXParser :: Parser Transformation +skewXParser = do + args <- functionParser "skewX" + return $ case args of + [x] -> SkewX x + _ -> TransformUnknown + +skewYParser :: Parser Transformation +skewYParser = do + args <- functionParser "skewY" + return $ case args of + [x] -> SkewY x + _ -> TransformUnknown + + +scaleParser :: Parser Transformation +scaleParser = do + args <- functionParser "scale" + return $ case args of + [x] -> Scale x Nothing + [x, y] -> Scale x (Just y) + _ -> TransformUnknown + +matrixParser :: Parser Transformation +matrixParser = do + args <- functionParser "matrix" + return $ case args of + [a, b, c, d, e, f] -> + TransformMatrix a b c d e f + _ -> TransformUnknown + +rotateParser :: Parser Transformation +rotateParser = do + args <- functionParser "rotate" + return $ case args of + [angle] -> Rotate angle Nothing + [angle, x, y] -> Rotate angle $ Just (x, y) + _ -> TransformUnknown +{- +rotate( [ ]), which specifies a rotation by degrees about a given point. + +If optional parameters and are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0]. + +If optional parameters and are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(, ) rotate() translate(-, -). + +skewX(), which specifies a skew transformation along the x-axis. + +skewY(), which specifies a skew transformation along the y-axis. + -} +gradientCommand :: Parser GradientPathCommand +gradientCommand = + (GLine OriginAbsolute <$> (string "L" *> mayPoint)) + <|> (GLine OriginRelative <$> (string "l" *> mayPoint)) + <|> (string "C" *> curveToArgs OriginAbsolute) + <|> (string "c" *> curveToArgs OriginRelative) + <|> (GClose <$ string "Z") + where + mayPoint = option Nothing $ Just <$> point + curveToArgs o = + GCurve o <$> (point <* commaWsp) + <*> (point <* commaWsp) + <*> mayPoint + +serializeGradientCommand :: GradientPathCommand -> String +serializeGradientCommand p = case p of + GLine OriginAbsolute points -> "L" ++ smp points + GLine OriginRelative points -> "l" ++ smp points + GClose -> "Z" + + GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c + GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c + where + sp = serializePoint + smp Nothing = "" + smp (Just pp) = serializePoint pp diff --git a/src/Graphics/SvgTree/Types.hs b/src/Graphics/SvgTree/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/Types.hs @@ -0,0 +1,2787 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | This module define all the types used in the definition +-- of a svg scene. +-- +-- Most of the types are lensified. +module Graphics.SvgTree.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( .. ) + + -- ** Mesh (gradient mesh) + , GradientPathCommand( .. ) + , MeshGradientType( .. ) + + , MeshGradient( .. ) + , HasMeshGradient( .. ) + + , MeshGradientRow( .. ) + , HasMeshGradientRow( .. ) + + , MeshGradientPatch( .. ) + , HasMeshGradientPatch( .. ) + + -- ** Image + , Image( .. ) + , HasImage( .. ) + + -- ** Use + , Use( .. ) + , HasUse( .. ) + + -- * Grouping primitives + -- ** Group + , Group( .. ) + , HasGroup( .. ) + + -- ** Symbol + , Symbol( .. ) + , groupOfSymbol + + -- ** Definitions + , Definitions( .. ) + , groupOfDefinitions + + -- * Text related types + -- ** Text + , Text( .. ) + , HasText( .. ) + , TextAnchor( .. ) + , textAt + + -- ** Text path + , TextPath( .. ) + , HasTextPath( .. ) + + , TextPathSpacing( .. ) + , TextPathMethod( .. ) + + -- ** Text span. + , TextSpanContent( .. ) + + , TextSpan( .. ) + , HasTextSpan( .. ) + + , TextInfo( .. ) + , HasTextInfo( .. ) + + , TextAdjust( .. ) + + -- * Marker definition + , Marker( .. ) + , Overflow( .. ) + , MarkerOrientation( .. ) + , MarkerUnit( .. ) + , HasMarker( .. ) + + -- * Gradient definition + , GradientStop( .. ) + , HasGradientStop( .. ) + + -- ** Linear Gradient + , LinearGradient( .. ) + , HasLinearGradient( .. ) + + -- ** Radial Gradient + , RadialGradient( .. ) + , HasRadialGradient( .. ) + + -- * Pattern definition + , Pattern( .. ) + , HasPattern( .. ) + + -- * Mask definition + , Mask( .. ) + , HasMask( .. ) + + -- * Clip path definition + , ClipPath( .. ) + , HasClipPath( .. ) + + -- * Aspect Ratio description + , PreserveAspectRatio( .. ) + , Alignment( .. ) + , MeetSlice( .. ) + , HasPreserveAspectRatio( .. ) + + -- * MISC functions + , isPathArc + , isPathWithArc + , nameOfTree + , zipTree + , mapTree + , foldTree + , toUserUnit + , mapNumber + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable (Foldable) +import Data.Monoid (Monoid (..)) +#endif + +import Codec.Picture (PixelRGBA8 (..)) +import Control.Lens (Lens, Lens', lens, view, (&), (.~), + (^.)) +import qualified Data.Foldable as F +import Data.Function (on) +import Data.List (inits) +import qualified Data.Map as M +import Data.Monoid (Last (..)) +import Data.Semigroup (Semigroup (..)) +import qualified Data.Text as T +import Graphics.SvgTree.CssTypes +import Linear hiding (angle) + +import Text.Printf + +-- | Basic coordinate type. +type Coord = Double + +-- | Real Point, fully determined and not +-- dependant of the rendering context. +type RPoint = V2 Coord + +-- | Possibly context dependant point. +type Point = (Number, Number) + +-- | Tell if a path command is absolute (in the current +-- user coordiante) or relative to the previous poitn. +data Origin + = OriginAbsolute -- ^ Next point in absolute coordinate + | OriginRelative -- ^ Next point relative to the previous + deriving (Eq, Show) + +data MeshGradientType + = GradientBilinear + | GradientBicubic + deriving (Eq, Show) + +-- | Path command definition. +data PathCommand + -- | 'M' or 'm' command + = MoveTo !Origin ![RPoint] + -- | Line to, 'L' or 'l' Svg path command. + | LineTo !Origin ![RPoint] + + -- | Equivalent to the 'H' or 'h' svg path command. + | HorizontalTo !Origin ![Coord] + -- | Equivalent to the 'V' or 'v' svg path command. + | VerticalTo !Origin ![Coord] + + -- | Cubic bezier, 'C' or 'c' command + | CurveTo !Origin ![(RPoint, RPoint, RPoint)] + -- | Smooth cubic bezier, equivalent to 'S' or 's' command + | SmoothCurveTo !Origin ![(RPoint, RPoint)] + -- | Quadratic bezier, 'Q' or 'q' command + | QuadraticBezier !Origin ![(RPoint, RPoint)] + -- | Quadratic bezier, 'T' or 't' command + | SmoothQuadraticBezierCurveTo !Origin ![RPoint] + -- | Eliptical arc, 'A' or 'a' command. + | EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)] + -- | Close the path, 'Z' or 'z' svg path command. + | EndPath + deriving (Eq, Show) + +-- | Description of path used in meshgradient tag +data GradientPathCommand + -- | Line to, 'L' or 'l' Svg path command. + = GLine !Origin !(Maybe RPoint) + -- | Cubic bezier, 'C' or 'c' command + | GCurve !Origin !RPoint !RPoint !(Maybe RPoint) + -- | 'Z' command + | GClose + deriving (Eq, Show) + +-- | Little helper function to build a point. +toPoint :: Number -> Number -> Point +toPoint = (,) + +-- | Tell if the path command is an EllipticalArc. +isPathArc :: PathCommand -> Bool +isPathArc (EllipticalArc _ _) = True +isPathArc _ = False + +-- | Tell if a full path contain an EllipticalArc. +isPathWithArc :: Foldable f => f PathCommand -> Bool +isPathWithArc = F.any isPathArc + +-- | 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) + +-- | This type represent the align information of the +-- preserveAspectRatio SVGattribute +data Alignment + = AlignNone -- ^ "none" value + | AlignxMinYMin -- "xMinYMin" value + | AlignxMidYMin -- ^ "xMidYMin" value + | AlignxMaxYMin -- ^ "xMaxYMin" value + | AlignxMinYMid -- ^ "xMinYMid" value + | AlignxMidYMid -- ^ "xMidYMid" value + | AlignxMaxYMid -- ^ "xMaxYMid" value + | AlignxMinYMax -- ^ "xMinYMax" value + | AlignxMidYMax -- ^ "xMidYMax" value + | AlignxMaxYMax -- ^ "xMaxYMax" value + deriving (Eq, Show) + +-- | This type represent the "meet or slice" information +-- of the preserveAspectRatio SVGattribute +data MeetSlice = Meet | Slice + deriving (Eq, Show) + +-- | Describe the content of the preserveAspectRatio attribute. +data PreserveAspectRatio = PreserveAspectRatio + { _aspectRatioDefer :: !Bool + , _aspectRatioAlign :: !Alignment + , _aspectRatioMeetSlice :: !(Maybe MeetSlice) + } + deriving (Eq, Show) + +instance WithDefaultSvg PreserveAspectRatio where + defaultSvg = PreserveAspectRatio + { _aspectRatioDefer = False + , _aspectRatioAlign = AlignxMidYMid + , _aspectRatioMeetSlice = Nothing + } + +-- | Describe how the line should be terminated +-- when stroking them. Describe the values of the +-- `stroke-linecap` attribute. +-- See `_strokeLineCap` +data Cap + = CapRound -- ^ End with a round (`round` value) + | CapButt -- ^ Define straight just at the end (`butt` value) + | CapSquare -- ^ Straight further of the ends (`square` value) + deriving (Eq, Show) + +-- | Define the possible values of the `stroke-linejoin` +-- attribute. +-- see `_strokeLineJoin` +data LineJoin + = JoinMiter -- ^ `miter` value + | JoinBevel -- ^ `bevel` value + | JoinRound -- ^ `round` value + deriving (Eq, Show) + +-- | Describe the different value which can be used +-- in the `fill` or `stroke` attributes. +data Texture + = ColorRef PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb) + | TextureRef String -- ^ Link to a complex texture (url(#name)) + | FillNone -- ^ Equivalent to the `none` value. + deriving (Eq, Show) + +-- | Describe the possile filling algorithms. +-- Map the values of the `fill-rule` attributes. +data FillRule + = FillEvenOdd -- ^ Correspond to the `evenodd` value. + | FillNonZero -- ^ Correspond to the `nonzero` value. + deriving (Eq, Show) + +-- | Describe the content of the `transformation` attribute. +-- see `_transform` and `transform`. +data Transformation + = -- | Directly encode the translation matrix. + TransformMatrix !Coord !Coord !Coord + !Coord !Coord !Coord + -- | Translation along a vector + | Translate !Double !Double + -- | Scaling on both axis or on X axis and Y axis. + | Scale !Double !(Maybe Double) + -- | Rotation around `(0, 0)` or around an optional + -- point. + | Rotate !Double !(Maybe (Double, Double)) + -- | Skew transformation along the X axis. + | SkewX !Double + -- | Skew transformation along the Y axis. + | SkewY !Double + -- | Unkown transformation, like identity. + | TransformUnknown + deriving (Eq, Show) + +-- | Convert the Transformation to a string which can be +-- directly used in a svg attributes. +serializeTransformation :: Transformation -> String +serializeTransformation t = case t of + TransformUnknown -> "" + TransformMatrix a b c d e f -> + printf "matrix(%g, %g, %g, %g, %g, %g)" a b c d e f + Translate x y -> printf "translate(%g, %g)" x y + Scale x Nothing -> printf "scale(%g)" x + Scale x (Just y) -> printf "scale(%g, %g)" x y + Rotate angle Nothing -> printf "rotate(%g)" angle + Rotate angle (Just (x, y))-> printf "rotate(%g, %g, %g)" angle x y + SkewX x -> printf "skewX(%g)" x + SkewY y -> printf "skewY(%g)" y + +-- | Transform a list of transformations to a string for svg +-- `transform` attributes. +serializeTransformations :: [Transformation] -> String +serializeTransformations = + unwords . fmap serializeTransformation + +-- | Class helping find the drawing attributes for all +-- the SVG attributes. +class WithDrawAttributes a where + -- | Lens which can be used to read/write primitives. + drawAttr :: Lens' a DrawAttributes + +-- | Define an empty 'default' element for the SVG tree. +-- It is used as base when parsing the element from XML. +class WithDefaultSvg a where + -- | The default element. + defaultSvg :: a + +-- | Classify the font style, used to search a matching +-- font in the FontCache. +data FontStyle + = FontStyleNormal + | FontStyleItalic + | FontStyleOblique + deriving (Eq, Show) + +-- | Tell where to anchor the text, where the position +-- given is realative to the text. +data TextAnchor + -- | The text with left aligned, or start at the postion + -- If the point is the '*' then the text will be printed + -- this way: + -- + -- > *THE_TEXT_TO_PRINT + -- + -- Equivalent to the `start` value. + = TextAnchorStart + -- | The text is middle aligned, so the text will be at + -- the left and right of the position: + -- + -- > THE_TEXT*TO_PRINT + -- + -- Equivalent to the `middle` value. + | TextAnchorMiddle + -- | The text is right aligned. + -- + -- > THE_TEXT_TO_PRINT* + -- + -- Equivalent to the `end` value. + | TextAnchorEnd + deriving (Eq, Show) + + +-- | Correspond to the possible values of the +-- the attributes which are either `none` or +-- `url(#elem)` +data ElementRef + = RefNone -- ^ Value for `none` + | Ref String -- ^ Equivalent to `url()` attribute. + deriving (Eq, Show) + +-- | This type define how to draw any primitives, +-- which color to use, how to stroke the primitives +-- and the potential transformations to use. +-- +-- All these attributes are propagated to the children. +data DrawAttributes = DrawAttributes + { -- | Attribute corresponding to the `stroke-width` + -- SVG attribute. + _strokeWidth :: !(Last Number) + -- | Correspond to the `stroke` attribute. + , _strokeColor :: !(Last Texture) + -- | Define the `stroke-opacity` attribute, the transparency + -- for the "border". + , _strokeOpacity :: !(Maybe Float) + -- | Correspond to the `stroke-linecap` SVG + -- attribute + , _strokeLineCap :: !(Last Cap) + -- | Correspond to the `stroke-linejoin` SVG + -- attribute + , _strokeLineJoin :: !(Last LineJoin) + -- | Define the distance of the miter join, correspond + -- to the `stroke-miterlimit` attritbue. + , _strokeMiterLimit :: !(Last Double) + -- | Define the filling color of the elements. Corresponding + -- to the `fill` attribute. + , _fillColor :: !(Last Texture) + -- | Define the `fill-opacity` attribute, the transparency + -- for the "content". + , _fillOpacity :: !(Maybe Float) + -- | Define the global or group opacity attribute. + , _groupOpacity :: !(Maybe Float) + -- | Content of the `transform` attribute + , _transform :: !(Maybe [Transformation]) + -- | Define the `fill-rule` used during the rendering. + , _fillRule :: !(Last FillRule) + -- | Define the `mask` attribute. + , _maskRef :: !(Last ElementRef) + -- | Define the `clip-path` attribute. + , _clipPathRef :: !(Last ElementRef) + -- | Define the `clip-rule` attribute. + , _clipRule :: !(Last FillRule) + -- | Map to the `class` attribute. Used for the CSS + -- rewriting. + , _attrClass :: ![T.Text] + -- | Map to the `id` attribute. Used for the CSS + -- rewriting. + , _attrId :: !(Maybe String) + -- | Define the start distance of the dashing pattern. + -- Correspond to the `stroke-dashoffset` attribute. + , _strokeOffset :: !(Last Number) + -- | Define the dashing pattern for the lines. Correspond + -- to the `stroke-dasharray` attribute. + , _strokeDashArray :: !(Last [Number]) + -- | Current size of the text, correspond to the + -- `font-size` SVG attribute. + , _fontSize :: !(Last Number) + -- | Define the possible fonts to be used for text rendering. + -- Map to the `font-family` attribute. + , _fontFamily :: !(Last [String]) + -- | Map to the `font-style` attribute. + , _fontStyle :: !(Last FontStyle) + -- | Define how to interpret the text position, correspond + -- to the `text-anchor` attribute. + , _textAnchor :: !(Last TextAnchor) + -- | Define the marker used for the start of the line. + -- Correspond to the `marker-start` attribute. + , _markerStart :: !(Last ElementRef) + -- | Define the marker used for every point of the + -- polyline/path Correspond to the `marker-mid` + -- attribute. + , _markerMid :: !(Last ElementRef) + -- | Define the marker used for the end of the line. + -- Correspond to the `marker-end` attribute. + , _markerEnd :: !(Last ElementRef) + } + deriving (Eq, Show) + + +-- | This primitive describe an unclosed suite of +-- segments. Correspond to the `` tag. +data PolyLine = PolyLine + { -- | drawing attributes of the polyline. + _polyLineDrawAttributes :: !DrawAttributes + + -- | Geometry definition of the polyline. + -- correspond to the `points` attribute + , _polyLinePoints :: ![RPoint] + } + deriving (Eq, Show) + + +instance WithDefaultSvg PolyLine where + defaultSvg = PolyLine + { _polyLineDrawAttributes = mempty + , _polyLinePoints = [] + } + +-- makeClassy ''PolyLine +-- | Lenses for the PolyLine type. +class HasPolyLine a where + polyLine :: Lens' a PolyLine + polyLineDrawAttributes :: Lens' a DrawAttributes + {-# INLINE polyLineDrawAttributes #-} + polyLineDrawAttributes = polyLine . polyLineDrawAttributes + + polyLinePoints :: Lens' a [RPoint] + {-# INLINE polyLinePoints #-} + polyLinePoints = polyLine . polyLinePoints + +instance HasPolyLine PolyLine where + polyLine = id + {-# INLINE polyLineDrawAttributes #-} + polyLineDrawAttributes f p = + fmap (\y -> p { _polyLineDrawAttributes = y }) (f $ _polyLineDrawAttributes p) + {-# INLINE polyLinePoints #-} + polyLinePoints f p = + fmap (\y -> p { _polyLinePoints = y }) (f $ _polyLinePoints p) + +instance WithDrawAttributes PolyLine where + drawAttr = polyLineDrawAttributes + +-- | Primitive decriving polygon composed +-- of segements. Correspond to the `` +-- tag +data Polygon = Polygon + { -- | Drawing attributes for the polygon. + _polygonDrawAttributes :: !DrawAttributes + -- | Points of the polygon. Correspond to + -- the `points` attributes. + , _polygonPoints :: ![RPoint] + } + deriving (Eq, Show) + +-- makeClassy ''Polygon +-- | Lenses for the Polygon type +class HasPolygon a where + polygon :: Lens' a Polygon + polygonDrawAttributes :: Lens' a DrawAttributes + {-# INLINE polygonDrawAttributes #-} + polygonPoints :: Lens' a [RPoint] + {-# INLINE polygonPoints #-} + polygonDrawAttributes = polygon . polygonDrawAttributes + polygonPoints = polygon . polygonPoints + +instance HasPolygon Polygon where + polygon = id + {-# INLINE polygonDrawAttributes #-} + polygonDrawAttributes f p = + fmap (\y -> p { _polygonDrawAttributes = y }) (f $ _polygonDrawAttributes p) + {-# INLINE polygonPoints #-} + polygonPoints f p = + fmap (\y -> p { _polygonPoints = y }) (f $ _polygonPoints p) + +instance WithDrawAttributes Polygon where + drawAttr = polygonDrawAttributes + +instance WithDefaultSvg Polygon where + defaultSvg = Polygon + { _polygonDrawAttributes = mempty + , _polygonPoints = [] + } + +-- | Define a simple line. Correspond to the +-- `` tag. +data Line = Line + { -- | Drawing attributes of line. + _lineDrawAttributes :: !DrawAttributes + -- | First point of the the line, correspond + -- to the `x1` and `y1` attributes. + , _linePoint1 :: !Point + -- | Second point of the the line, correspond + -- to the `x2` and `y2` attributes. + , _linePoint2 :: !Point + } + deriving (Eq, Show) + +-- makeClassy ''Line +-- | Lenses for the Line type. +class HasLine a where + line :: Lens' a Line + lineDrawAttributes :: Lens' a DrawAttributes + lineDrawAttributes = line . lineDrawAttributes + {-# INLINE lineDrawAttributes #-} + linePoint1 :: Lens' a Point + linePoint1 = line . linePoint1 + {-# INLINE linePoint1 #-} + linePoint2 :: Lens' a Point + linePoint2 = line . linePoint2 + {-# INLINE linePoint2 #-} + +instance HasLine Line where + line = id + {-# INLINE lineDrawAttributes #-} + lineDrawAttributes f l = + fmap (\y -> l { _lineDrawAttributes = y }) (f (_lineDrawAttributes l)) + {-# INLINE linePoint1 #-} + linePoint1 f l = + fmap (\y -> l { _linePoint1 = y }) (f (_linePoint1 l)) + {-# INLINE linePoint2 #-} + linePoint2 f l = + fmap (\y -> l { _linePoint2 = y }) (f (_linePoint2 l)) + +instance WithDrawAttributes Line where + drawAttr = lineDrawAttributes + +instance WithDefaultSvg Line where + defaultSvg = Line + { _lineDrawAttributes = mempty + , _linePoint1 = zeroPoint + , _linePoint2 = zeroPoint + } + where zeroPoint = (Num 0, Num 0) + +-- | Define a rectangle. Correspond to +-- `` svg tag. +data Rectangle = Rectangle + { -- | Rectangle drawing attributes. + _rectDrawAttributes :: !DrawAttributes + -- | Upper left corner of the rectangle, correspond + -- to the attributes `x` and `y`. + , _rectUpperLeftCorner :: !Point + -- | Rectangle width, correspond, strangely, to + -- the `width` attribute. + , _rectWidth :: !(Maybe Number) + -- | Rectangle height, correspond, amazingly, to + -- the `height` attribute. + , _rectHeight :: !(Maybe Number) + -- | Define the rounded corner radius radius + -- of the rectangle. Correspond to the `rx` and + -- `ry` attributes. + , _rectCornerRadius :: !(Maybe Number, Maybe Number) + } + deriving (Eq, Show) + +-- makeClassy ''Rectangle +-- | Lenses for the Rectangle type. +class HasRectangle a where + rectangle :: Lens' a Rectangle + rectCornerRadius :: Lens' a (Maybe Number, Maybe Number) + {-# INLINE rectCornerRadius #-} + rectCornerRadius = rectangle . rectCornerRadius + + rectDrawAttributes :: Lens' a DrawAttributes + {-# INLINE rectDrawAttributes #-} + rectDrawAttributes = rectangle . rectDrawAttributes + + rectHeight :: Lens' a (Maybe Number) + {-# INLINE rectHeight #-} + rectHeight = rectangle . rectHeight + + rectUpperLeftCorner :: Lens' a Point + {-# INLINE rectUpperLeftCorner #-} + rectUpperLeftCorner = rectangle . rectUpperLeftCorner + + rectWidth :: Lens' a (Maybe Number) + {-# INLINE rectWidth #-} + rectWidth = rectangle . rectWidth + +instance HasRectangle Rectangle where + rectangle = id + {-# INLINE rectCornerRadius #-} + rectCornerRadius f attr = + fmap (\y -> attr { _rectCornerRadius = y }) (f $ _rectCornerRadius attr) + {-# INLINE rectDrawAttributes #-} + rectDrawAttributes f attr = + fmap (\y -> attr { _rectDrawAttributes = y }) (f $ _rectDrawAttributes attr) + {-# INLINE rectHeight #-} + rectHeight f attr = + fmap (\y -> attr { _rectHeight = y }) (f $ _rectHeight attr) + {-# INLINE rectUpperLeftCorner #-} + rectUpperLeftCorner f attr = + fmap (\y -> attr { _rectUpperLeftCorner = y }) (f $ _rectUpperLeftCorner attr) + {-# INLINE rectWidth #-} + rectWidth f attr = + fmap (\y -> attr { _rectWidth = y }) (f $ _rectWidth attr) + +instance WithDrawAttributes Rectangle where + drawAttr = rectDrawAttributes + +instance WithDefaultSvg Rectangle where + defaultSvg = Rectangle + { _rectDrawAttributes = mempty + , _rectUpperLeftCorner = (Num 0, Num 0) + , _rectWidth = Nothing + , _rectHeight = Nothing + , _rectCornerRadius = (Nothing, Nothing) + } + +-- | Type mapping the `` svg tag. +data Path = Path + { -- | Drawing attributes of the path. + _pathDrawAttributes :: !DrawAttributes + -- | Definition of the path, correspond to the + -- `d` attributes. + , _pathDefinition :: ![PathCommand] + } + deriving (Eq, Show) + +-- makeClassy ''Path +-- | Lenses for the Path type +class HasPath c_alhy where + path :: Lens' c_alhy Path + pathDefinition :: Lens' c_alhy [PathCommand] + {-# INLINE pathDefinition #-} + pathDefinition = path . pathDefinition + + pathDrawAttributes :: Lens' c_alhy DrawAttributes + {-# INLINE pathDrawAttributes #-} + pathDrawAttributes = path . pathDrawAttributes + +instance HasPath Path where + path = id + {-# INLINE pathDefinition #-} + pathDefinition f attr = + fmap (\y -> attr { _pathDefinition = y }) (f $ _pathDefinition attr) + {-# INLINE pathDrawAttributes #-} + pathDrawAttributes f attr = + fmap (\y -> attr { _pathDrawAttributes = y }) (f $ _pathDrawAttributes attr) + +instance WithDrawAttributes Path where + drawAttr = pathDrawAttributes + +instance WithDefaultSvg Path where + defaultSvg = Path + { _pathDrawAttributes = mempty + , _pathDefinition = [] + } + +-- | Define a SVG group, corresponding `` tag. +data Group a = Group + { -- | Group drawing attributes, propagated to all of its + -- children. + _groupDrawAttributes :: !DrawAttributes + -- | Content of the group, corresponding to all the tags + -- inside the `` tag. + , _groupChildren :: ![a] + -- | Mapped to the attribute `viewBox` + , _groupViewBox :: !(Maybe (Double, Double, Double, Double)) + -- | used for symbols only + , _groupAspectRatio :: !PreserveAspectRatio + } + deriving (Eq, Show) + +-- makeClassy ''Group +-- | Lenses associated to the Group type. +class HasGroup g a | g -> a where + group :: Lens' g (Group a) + groupAspectRatio :: Lens' g PreserveAspectRatio + {-# INLINE groupAspectRatio #-} + groupAspectRatio = group . groupAspectRatio + + groupChildren :: Lens' g [a] + {-# INLINE groupChildren #-} + groupChildren = group . groupChildren + + groupDrawAttributes :: Lens' g DrawAttributes + {-# INLINE groupDrawAttributes #-} + groupDrawAttributes = group . groupDrawAttributes + + groupViewBox :: Lens' g (Maybe (Double, Double, Double, Double)) + {-# INLINE groupViewBox #-} + groupViewBox = group . groupViewBox + +instance HasGroup (Group a) a where + group = id + {-# INLINE groupAspectRatio #-} + groupAspectRatio f attr = + fmap (\y -> attr { _groupAspectRatio = y }) (f $ _groupAspectRatio attr) + + {-# INLINE groupChildren #-} + groupChildren f attr = + fmap (\y -> attr { _groupChildren = y }) (f $ _groupChildren attr) + + {-# INLINE groupDrawAttributes #-} + groupDrawAttributes f attr = + fmap (\y -> attr { _groupDrawAttributes = y }) (f $ _groupDrawAttributes attr) + + {-# INLINE groupViewBox #-} + groupViewBox f attr = + fmap (\y -> attr { _groupViewBox = y }) (f $ _groupViewBox attr) + +instance WithDrawAttributes (Group a) where + drawAttr = groupDrawAttributes + +instance WithDefaultSvg (Group a) where + defaultSvg = Group + { _groupDrawAttributes = mempty + , _groupChildren = [] + , _groupViewBox = Nothing + , _groupAspectRatio = defaultSvg + } + +-- | Define the `` tag, equivalent to +-- a hidden named group. +newtype Symbol a = + Symbol { _groupOfSymbol :: Group a } + deriving (Eq, Show) + +-- makeLenses ''Symbol +-- | Lenses associated with the Symbol type. +groupOfSymbol :: Lens (Symbol s) (Symbol t) (Group s) (Group t) +{-# INLINE groupOfSymbol #-} +groupOfSymbol f = fmap Symbol . f . _groupOfSymbol + +instance WithDrawAttributes (Symbol a) where + drawAttr = groupOfSymbol . drawAttr + +instance WithDefaultSvg (Symbol a) where + defaultSvg = Symbol defaultSvg + +-- | Define the `` tag, equivalent to +-- a named symbol. +newtype Definitions a = + Definitions { _groupOfDefinitions :: Group a } + deriving (Eq, Show) + +-- makeLenses ''Definitions +-- | Lenses associated with the Definitions type. +groupOfDefinitions :: Lens (Definitions s) (Definitions t) (Group s) (Group t) +{-# INLINE groupOfDefinitions #-} +groupOfDefinitions f = fmap Definitions . f . _groupOfDefinitions + +instance WithDrawAttributes (Definitions a) where + drawAttr = groupOfDefinitions . drawAttr + +instance WithDefaultSvg (Definitions a) where + defaultSvg = Definitions defaultSvg + +-- | Define a ``. +data Circle = Circle + { -- | Drawing attributes of the circle. + _circleDrawAttributes :: !DrawAttributes + -- | Define the center of the circle, describe + -- the `cx` and `cy` attributes. + , _circleCenter :: !Point + -- | Radius of the circle, equivalent to the `r` + -- attribute. + , _circleRadius :: !Number + } + deriving (Eq, Show) + +-- makeClassy ''Circle +-- | Lenses for the Circle type. +class HasCircle a where + circle :: Lens' a Circle + circleCenter :: Lens' a Point + {-# INLINE circleCenter #-} + circleCenter = circle . circleCenter + + circleDrawAttributes :: Lens' a DrawAttributes + {-# INLINE circleDrawAttributes #-} + circleDrawAttributes = circle . circleDrawAttributes + + circleRadius :: Lens' a Number + {-# INLINE circleRadius #-} + circleRadius = circle . circleRadius + +instance HasCircle Circle where + circle = id + {-# INLINE circleCenter #-} + circleCenter f attr = + fmap (\y -> attr { _circleCenter = y }) (f $ _circleCenter attr) + {-# INLINE circleDrawAttributes #-} + circleDrawAttributes f attr = + fmap (\y -> attr { _circleDrawAttributes = y }) (f $ _circleDrawAttributes attr) + {-# INLINE circleRadius #-} + circleRadius f attr = + fmap (\y -> attr { _circleRadius = y }) (f $ _circleRadius attr) + +instance WithDrawAttributes Circle where + drawAttr = circleDrawAttributes + +instance WithDefaultSvg Circle where + defaultSvg = Circle + { _circleDrawAttributes = mempty + , _circleCenter = (Num 0, Num 0) + , _circleRadius = Num 0 + } + +-- | Define an `` +data Ellipse = Ellipse + { -- | Drawing attributes of the ellipse. + _ellipseDrawAttributes :: !DrawAttributes + -- | Center of the ellipse, map to the `cx` + -- and `cy` attributes. + , _ellipseCenter :: !Point + -- | Radius along the X axis, map the + -- `rx` attribute. + , _ellipseXRadius :: !Number + -- | Radius along the Y axis, map the + -- `ry` attribute. + , _ellipseYRadius :: !Number + } + deriving (Eq, Show) + +-- makeClassy ''Ellipse +-- | Lenses for the ellipse type. +class HasEllipse c_amWt where + ellipse :: Lens' c_amWt Ellipse + ellipseCenter :: Lens' c_amWt Point + {-# INLINE ellipseCenter #-} + ellipseDrawAttributes :: Lens' c_amWt DrawAttributes + {-# INLINE ellipseDrawAttributes #-} + ellipseXRadius :: Lens' c_amWt Number + {-# INLINE ellipseXRadius #-} + ellipseYRadius :: Lens' c_amWt Number + {-# INLINE ellipseYRadius #-} + ellipseCenter = ((.) ellipse) ellipseCenter + ellipseDrawAttributes = ((.) ellipse) ellipseDrawAttributes + ellipseXRadius = ((.) ellipse) ellipseXRadius + ellipseYRadius = ((.) ellipse) ellipseYRadius + +instance HasEllipse Ellipse where + {-# INLINE ellipseCenter #-} + {-# INLINE ellipseDrawAttributes #-} + {-# INLINE ellipseXRadius #-} + {-# INLINE ellipseYRadius #-} + ellipse = id + ellipseCenter f attr = + fmap (\y -> attr { _ellipseCenter = y }) (f $ _ellipseCenter attr) + ellipseDrawAttributes f attr = + fmap (\y -> attr { _ellipseDrawAttributes = y }) (f $ _ellipseDrawAttributes attr) + ellipseXRadius f attr = + fmap (\y -> attr { _ellipseXRadius = y }) (f $ _ellipseXRadius attr) + ellipseYRadius f attr = + fmap (\y -> attr { _ellipseYRadius = y }) (f $ _ellipseYRadius attr) + +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 a color stop for the gradients. Represent +-- the `` SVG tag. +data GradientStop = GradientStop + { -- | Gradient offset between 0 and 1, correspond + -- to the `offset` attribute. + _gradientOffset :: !Float + -- | Color of the gradient stop. Correspond + -- to the `stop-color` attribute. + , _gradientColor :: !PixelRGBA8 + -- | Path command used in mesh patch + , _gradientPath :: !(Maybe GradientPathCommand) + -- | Stop color opacity + , _gradientOpacity :: !(Maybe Float) + } + deriving (Eq, Show) + +-- makeClassy ''GradientStop +-- | Lenses for the GradientStop type. +class HasGradientStop c_anhM where + gradientStop :: Lens' c_anhM GradientStop + gradientColor :: Lens' c_anhM PixelRGBA8 + {-# INLINE gradientColor #-} + gradientOffset :: Lens' c_anhM Float + {-# INLINE gradientOffset #-} + gradientOpacity :: Lens' c_anhM (Maybe Float) + {-# INLINE gradientOpacity #-} + gradientPath :: Lens' c_anhM (Maybe GradientPathCommand) + {-# INLINE gradientPath #-} + gradientColor = ((.) gradientStop) gradientColor + gradientOffset = ((.) gradientStop) gradientOffset + gradientOpacity = ((.) gradientStop) gradientOpacity + gradientPath = ((.) gradientStop) gradientPath + +instance HasGradientStop GradientStop where + {-# INLINE gradientColor #-} + {-# INLINE gradientOffset #-} + {-# INLINE gradientOpacity #-} + {-# INLINE gradientPath #-} + gradientStop = id + gradientColor f attr = + fmap (\y -> attr { _gradientColor = y }) (f $ _gradientColor attr) + gradientOffset f attr = + fmap (\y -> attr { _gradientOffset = y }) (f $ _gradientOffset attr) + gradientOpacity f attr = + fmap (\y -> attr { _gradientOpacity = y }) (f $ _gradientOpacity attr) + gradientPath f attr = + fmap (\y -> attr { _gradientPath = y }) (f $ _gradientPath attr) + +instance WithDefaultSvg GradientStop where + defaultSvg = GradientStop + { _gradientOffset = 0.0 + , _gradientColor = PixelRGBA8 0 0 0 255 + , _gradientPath = Nothing + , _gradientOpacity = Nothing + } + + +-- | Define `` SVG tag +data MeshGradientPatch = MeshGradientPatch + { -- | List of stop, from 2 to 4 in a patch + _meshGradientPatchStops :: ![GradientStop] + } + deriving (Eq, Show) + +-- makeClassy ''MeshGradientPatch +class HasMeshGradientPatch c_annx where + meshGradientPatch :: Lens' c_annx MeshGradientPatch + meshGradientPatchStops :: Lens' c_annx [GradientStop] + {-# INLINE meshGradientPatchStops #-} + meshGradientPatchStops = meshGradientPatch . meshGradientPatchStops + +instance HasMeshGradientPatch MeshGradientPatch where + {-# INLINE meshGradientPatchStops #-} + meshGradientPatch = id + meshGradientPatchStops f m = + fmap (\y -> m { _meshGradientPatchStops = y }) . f $ _meshGradientPatchStops m + +instance WithDefaultSvg MeshGradientPatch where + defaultSvg = MeshGradientPatch [] + +-- | Define a `` tag. +data MeshGradientRow = MeshGradientRow + { -- | List of patch in a row + _meshGradientRowPatches :: ![MeshGradientPatch] + } + deriving (Eq, Show) + +-- makeClassy ''MeshGradientRow +class HasMeshGradientRow c_antr where + meshGradientRow :: Lens' c_antr MeshGradientRow + meshGradientRowPatches :: Lens' c_antr [MeshGradientPatch] + {-# INLINE meshGradientRowPatches #-} + meshGradientRowPatches = meshGradientRow . meshGradientRowPatches + +instance HasMeshGradientRow MeshGradientRow where + {-# INLINE meshGradientRowPatches #-} + meshGradientRow = id + meshGradientRowPatches f m = + fmap (\y -> m { _meshGradientRowPatches = y }) . f $ _meshGradientRowPatches m + +instance WithDefaultSvg MeshGradientRow where + defaultSvg = MeshGradientRow [] + + +-- | Define a `` tag. +data MeshGradient = MeshGradient + { _meshGradientDrawAttributes :: !DrawAttributes + -- | Original x coordinate of the mesh gradient + , _meshGradientX :: !Number + -- | Original y coordinate of the mesh gradient + , _meshGradientY :: !Number + -- | Type of color interpolation to use + , _meshGradientType :: !MeshGradientType + -- | Coordiante system to use + , _meshGradientUnits :: !CoordinateUnits + -- | Optional transform + , _meshGradientTransform :: ![Transformation] + -- | List of patch rows in the the mesh. + , _meshGradientRows :: ![MeshGradientRow] + } + deriving (Eq, Show) + +-- makeClassy ''MeshGradient +class HasMeshGradient c_anxG where + meshGradient :: Lens' c_anxG MeshGradient + meshGradientDrawAttributes :: Lens' c_anxG DrawAttributes + {-# INLINE meshGradientDrawAttributes #-} + meshGradientRows :: Lens' c_anxG [MeshGradientRow] + {-# INLINE meshGradientRows #-} + meshGradientTransform :: Lens' c_anxG [Transformation] + {-# INLINE meshGradientTransform #-} + meshGradientType :: Lens' c_anxG MeshGradientType + {-# INLINE meshGradientType #-} + meshGradientUnits :: Lens' c_anxG CoordinateUnits + {-# INLINE meshGradientUnits #-} + meshGradientX :: Lens' c_anxG Number + {-# INLINE meshGradientX #-} + meshGradientY :: Lens' c_anxG Number + {-# INLINE meshGradientY #-} + meshGradientDrawAttributes + = ((.) meshGradient) meshGradientDrawAttributes + meshGradientRows = ((.) meshGradient) meshGradientRows + meshGradientTransform = ((.) meshGradient) meshGradientTransform + meshGradientType = ((.) meshGradient) meshGradientType + meshGradientUnits = ((.) meshGradient) meshGradientUnits + meshGradientX = ((.) meshGradient) meshGradientX + meshGradientY = ((.) meshGradient) meshGradientY +instance HasMeshGradient MeshGradient where + {-# INLINE meshGradientDrawAttributes #-} + {-# INLINE meshGradientRows #-} + {-# INLINE meshGradientTransform #-} + {-# INLINE meshGradientType #-} + {-# INLINE meshGradientUnits #-} + {-# INLINE meshGradientX #-} + {-# INLINE meshGradientY #-} + meshGradient = id + meshGradientDrawAttributes f attr = + fmap (\y -> attr { _meshGradientDrawAttributes = y }) (f $ _meshGradientDrawAttributes attr) + meshGradientRows f attr = + fmap (\y -> attr { _meshGradientRows = y }) (f $ _meshGradientRows attr) + meshGradientTransform f attr = + fmap (\y -> attr { _meshGradientTransform = y }) (f $ _meshGradientTransform attr) + meshGradientType f attr = + fmap (\y -> attr { _meshGradientType = y }) (f $ _meshGradientType attr) + meshGradientUnits f attr = + fmap (\y -> attr { _meshGradientUnits = y }) (f $ _meshGradientUnits attr) + meshGradientX f attr = + fmap (\y -> attr { _meshGradientX = y }) (f $ _meshGradientX attr) + meshGradientY f attr = + fmap (\y -> attr { _meshGradientY = y }) (f $ _meshGradientY attr) + +instance WithDrawAttributes MeshGradient where + drawAttr = meshGradientDrawAttributes + +instance WithDefaultSvg MeshGradient where + defaultSvg = MeshGradient + { _meshGradientDrawAttributes = mempty + , _meshGradientX = Percent 0 + , _meshGradientY = Percent 0 + , _meshGradientType = GradientBilinear + , _meshGradientUnits = CoordBoundingBox + , _meshGradientTransform = mempty + , _meshGradientRows = mempty + } + + +-- | Define an `` tag. +data Image = Image + { -- | Drawing attributes of the image + _imageDrawAttributes :: !DrawAttributes + -- | Position of the image referenced by its + -- upper left corner. + , _imageCornerUpperLeft :: !Point + -- | Image width + , _imageWidth :: !Number + -- | Image Height + , _imageHeight :: !Number + -- | Image href, pointing to the real image. + , _imageHref :: !String + -- | preserveAspectRatio attribute + , _imageAspectRatio :: !PreserveAspectRatio + } + deriving (Eq, Show) + +-- makeClassy ''Image +-- | Lenses for the Image type. +class HasImage c_anI7 where + image :: Lens' c_anI7 Image + imageAspectRatio :: Lens' c_anI7 PreserveAspectRatio + {-# INLINE imageAspectRatio #-} + imageCornerUpperLeft :: Lens' c_anI7 Point + {-# INLINE imageCornerUpperLeft #-} + imageDrawAttributes :: Lens' c_anI7 DrawAttributes + {-# INLINE imageDrawAttributes #-} + imageHeight :: Lens' c_anI7 Number + {-# INLINE imageHeight #-} + imageHref :: Lens' c_anI7 String + {-# INLINE imageHref #-} + imageWidth :: Lens' c_anI7 Number + {-# INLINE imageWidth #-} + imageAspectRatio = ((.) image) imageAspectRatio + imageCornerUpperLeft = ((.) image) imageCornerUpperLeft + imageDrawAttributes = ((.) image) imageDrawAttributes + imageHeight = ((.) image) imageHeight + imageHref = ((.) image) imageHref + imageWidth = ((.) image) imageWidth +instance HasImage Image where + {-# INLINE imageAspectRatio #-} + {-# INLINE imageCornerUpperLeft #-} + {-# INLINE imageDrawAttributes #-} + {-# INLINE imageHeight #-} + {-# INLINE imageHref #-} + {-# INLINE imageWidth #-} + image = id + imageAspectRatio f attr = + fmap (\y -> attr { _imageAspectRatio = y }) (f $ _imageAspectRatio attr) + imageCornerUpperLeft f attr = + fmap (\y -> attr { _imageCornerUpperLeft = y }) (f $ _imageCornerUpperLeft attr) + imageDrawAttributes f attr = + fmap (\y -> attr { _imageDrawAttributes = y }) (f $ _imageDrawAttributes attr) + imageHeight f attr = + fmap (\y -> attr { _imageHeight = y }) (f $ _imageHeight attr) + imageHref f attr = + fmap (\y -> attr { _imageHref = y }) (f $ _imageHref attr) + imageWidth f attr = + fmap (\y -> attr { _imageWidth = y }) (f $ _imageWidth attr) + +instance WithDrawAttributes Image where + drawAttr = imageDrawAttributes + +instance WithDefaultSvg Image where + defaultSvg = Image + { _imageDrawAttributes = mempty + , _imageCornerUpperLeft = (Num 0, Num 0) + , _imageWidth = Num 0 + , _imageHeight = Num 0 + , _imageHref = "" + , _imageAspectRatio = defaultSvg + } + +-- | Define an `` for a named content. +-- Every named content can be reused in the +-- document using this element. +data Use = Use + { -- | Position where to draw the "used" element. + -- Correspond to the `x` and `y` attributes. + _useBase :: Point + -- | Referenced name, correspond to `xlink:href` + -- attribute. + , _useName :: String + -- | Define the width of the region where + -- to place the element. Map to the `width` + -- attribute. + , _useWidth :: Maybe Number + -- | Define the height of the region where + -- to place the element. Map to the `height` + -- attribute. + , _useHeight :: Maybe Number + -- | Use draw attributes. + , _useDrawAttributes :: DrawAttributes + } + deriving (Eq, Show) + +-- makeClassy ''Use +-- | Lenses for the Use type. +class HasUse c_anR3 where + use :: Lens' c_anR3 Use + useBase :: Lens' c_anR3 Point + {-# INLINE useBase #-} + useDrawAttributes :: Lens' c_anR3 DrawAttributes + {-# INLINE useDrawAttributes #-} + useHeight :: Lens' c_anR3 (Maybe Number) + {-# INLINE useHeight #-} + useName :: Lens' c_anR3 String + {-# INLINE useName #-} + useWidth :: Lens' c_anR3 (Maybe Number) + {-# INLINE useWidth #-} + useBase = ((.) use) useBase + useDrawAttributes = ((.) use) useDrawAttributes + useHeight = ((.) use) useHeight + useName = ((.) use) useName + useWidth = ((.) use) useWidth +instance HasUse Use where + {-# INLINE useBase #-} + {-# INLINE useDrawAttributes #-} + {-# INLINE useHeight #-} + {-# INLINE useName #-} + {-# INLINE useWidth #-} + use = id + useBase f attr = + fmap (\y -> attr { _useBase = y }) (f $ _useBase attr) + useDrawAttributes f attr = + fmap (\y -> attr { _useDrawAttributes = y }) (f $ _useDrawAttributes attr) + useHeight f attr = + fmap (\y -> attr { _useHeight = y }) (f $ _useHeight attr) + useName f attr = + fmap (\y -> attr { _useName = y }) (f $ _useName attr) + useWidth f attr = + fmap (\y -> attr { _useWidth = y }) (f $ _useWidth attr) + +instance WithDrawAttributes Use where + drawAttr = useDrawAttributes + +instance WithDefaultSvg Use where + defaultSvg = Use + { _useBase = (Num 0, Num 0) + , _useName = "" + , _useWidth = Nothing + , _useHeight = Nothing + , _useDrawAttributes = mempty + } + +-- | Define position information associated to +-- `` or `` svg tag. +data TextInfo = TextInfo + { _textInfoX :: ![Number] -- ^ `x` attribute. + , _textInfoY :: ![Number] -- ^ `y` attribute. + , _textInfoDX :: ![Number] -- ^ `dx` attribute. + , _textInfoDY :: ![Number] -- ^ `dy` attribute. + , _textInfoRotate :: ![Double] -- ^ `rotate` attribute. + , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute. + } + deriving (Eq, Show) + +instance Semigroup TextInfo where + (<>) (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) + +instance Monoid TextInfo where + mempty = TextInfo [] [] [] [] [] Nothing + mappend = (<>) + +-- makeClassy ''TextInfo +-- | Lenses for the TextInfo type. +class HasTextInfo c_ao0m where + textInfo :: Lens' c_ao0m TextInfo + textInfoDX :: Lens' c_ao0m [Number] + {-# INLINE textInfoDX #-} + textInfoDY :: Lens' c_ao0m [Number] + {-# INLINE textInfoDY #-} + textInfoLength :: Lens' c_ao0m (Maybe Number) + {-# INLINE textInfoLength #-} + textInfoRotate :: Lens' c_ao0m [Double] + {-# INLINE textInfoRotate #-} + textInfoX :: Lens' c_ao0m [Number] + {-# INLINE textInfoX #-} + textInfoY :: Lens' c_ao0m [Number] + {-# INLINE textInfoY #-} + textInfoDX = ((.) textInfo) textInfoDX + textInfoDY = ((.) textInfo) textInfoDY + textInfoLength = ((.) textInfo) textInfoLength + textInfoRotate = ((.) textInfo) textInfoRotate + textInfoX = ((.) textInfo) textInfoX + textInfoY = ((.) textInfo) textInfoY +instance HasTextInfo TextInfo where + {-# INLINE textInfoDX #-} + {-# INLINE textInfoDY #-} + {-# INLINE textInfoLength #-} + {-# INLINE textInfoRotate #-} + {-# INLINE textInfoX #-} + {-# INLINE textInfoY #-} + textInfo = id + textInfoDX f attr = + fmap (\y -> attr { _textInfoDX = y }) (f $ _textInfoDX attr) + textInfoDY f attr = + fmap (\y -> attr { _textInfoDY = y }) (f $ _textInfoDY attr) + textInfoLength f attr = + fmap (\y -> attr { _textInfoLength = y }) (f $ _textInfoLength attr) + textInfoRotate f attr = + fmap (\y -> attr { _textInfoRotate = y }) (f $ _textInfoRotate attr) + textInfoX f attr = + fmap (\y -> attr { _textInfoX = y }) (f $ _textInfoX attr) + textInfoY f attr = + fmap (\y -> attr { _textInfoY = y }) (f $ _textInfoY attr) + +instance WithDefaultSvg TextInfo where + defaultSvg = mempty + +-- | Define the content of a `` tag. +data TextSpanContent + = SpanText !T.Text -- ^ Raw text + | SpanTextRef !String -- ^ Equivalent to a `` + | SpanSub !TextSpan -- ^ Define a `` + deriving (Eq, Show) + +-- | Define a `` tag. +data TextSpan = TextSpan + { -- | Placing information for the text. + _spanInfo :: !TextInfo + -- | Drawing attributes for the text span. + , _spanDrawAttributes :: !DrawAttributes + -- | Content of the span. + , _spanContent :: ![TextSpanContent] + } + deriving (Eq, Show) + +-- makeClassy ''TextSpan +-- | Lenses for the TextSpan type. +class HasTextSpan c_aobD where + textSpan :: Lens' c_aobD TextSpan + spanContent :: Lens' c_aobD [TextSpanContent] + {-# INLINE spanContent #-} + spanDrawAttributes :: Lens' c_aobD DrawAttributes + {-# INLINE spanDrawAttributes #-} + spanInfo :: Lens' c_aobD TextInfo + {-# INLINE spanInfo #-} + spanContent = ((.) textSpan) spanContent + spanDrawAttributes = ((.) textSpan) spanDrawAttributes + spanInfo = ((.) textSpan) spanInfo +instance HasTextSpan TextSpan where + {-# INLINE spanContent #-} + {-# INLINE spanDrawAttributes #-} + {-# INLINE spanInfo #-} + textSpan = id + spanContent f attr = + fmap (\y -> attr { _spanContent = y }) (f $ _spanContent attr) + spanDrawAttributes f attr = + fmap (\y -> attr { _spanDrawAttributes = y }) (f $ _spanDrawAttributes attr) + spanInfo f attr = + fmap (\y -> attr { _spanInfo = y }) (f $ _spanInfo attr) + +instance WithDefaultSvg TextSpan where + defaultSvg = TextSpan + { _spanInfo = defaultSvg + , _spanDrawAttributes = mempty + , _spanContent = mempty + } + +-- | Describe the content of the `method` attribute on +-- text path. +data TextPathMethod + = TextPathAlign -- ^ Map to the `align` value. + | TextPathStretch -- ^ Map to the `stretch` value. + deriving (Eq, Show) + +-- | Describe the content of the `spacing` text path +-- attribute. +data TextPathSpacing + = TextPathSpacingExact -- ^ Map to the `exact` value. + | TextPathSpacingAuto -- ^ Map to the `auto` value. + deriving (Eq, Show) + +-- | Describe the `` SVG tag. +data TextPath = TextPath + { -- | Define the beginning offset on the path, + -- the `startOffset` attribute. + _textPathStartOffset :: !Number + -- | Define the `xlink:href` attribute. + , _textPathName :: !String + -- | Correspond to the `method` attribute. + , _textPathMethod :: !TextPathMethod + -- | Correspond to the `spacing` attribute. + , _textPathSpacing :: !TextPathSpacing + -- | Real content of the path. + , _textPathData :: ![PathCommand] + } + deriving (Eq, Show) + +-- makeClassy ''TextPath +-- | Lenses for the TextPath type. +class HasTextPath c_aojU where + textPath :: Lens' c_aojU TextPath + textPathData :: Lens' c_aojU [PathCommand] + {-# INLINE textPathData #-} + textPathMethod :: Lens' c_aojU TextPathMethod + {-# INLINE textPathMethod #-} + textPathName :: Lens' c_aojU String + {-# INLINE textPathName #-} + textPathSpacing :: Lens' c_aojU TextPathSpacing + {-# INLINE textPathSpacing #-} + textPathStartOffset :: Lens' c_aojU Number + {-# INLINE textPathStartOffset #-} + textPathData = ((.) textPath) textPathData + textPathMethod = ((.) textPath) textPathMethod + textPathName = ((.) textPath) textPathName + textPathSpacing = ((.) textPath) textPathSpacing + textPathStartOffset = ((.) textPath) textPathStartOffset +instance HasTextPath TextPath where + {-# INLINE textPathData #-} + {-# INLINE textPathMethod #-} + {-# INLINE textPathName #-} + {-# INLINE textPathSpacing #-} + {-# INLINE textPathStartOffset #-} + textPath = id + textPathData f attr = + fmap (\y -> attr { _textPathData = y }) (f $ _textPathData attr) + textPathMethod f attr = + fmap (\y -> attr { _textPathMethod = y }) (f $ _textPathMethod attr) + textPathName f attr = + fmap (\y -> attr { _textPathName = y }) (f $ _textPathName attr) + textPathSpacing f attr = + fmap (\y -> attr { _textPathSpacing = y }) (f $ _textPathSpacing attr) + textPathStartOffset f attr = + fmap (\y -> attr { _textPathStartOffset = y }) (f $ _textPathStartOffset attr) + +instance WithDefaultSvg TextPath where + defaultSvg = TextPath + { _textPathStartOffset = Num 0 + , _textPathName = mempty + , _textPathMethod = TextPathAlign + , _textPathSpacing = TextPathSpacingExact + , _textPathData = [] + } + +-- | Define the possible values of the `lengthAdjust` +-- attribute. +data TextAdjust + = TextAdjustSpacing -- ^ Value `spacing` + | TextAdjustSpacingAndGlyphs -- ^ Value `spacingAndGlyphs` + deriving (Eq, Show) + +-- | Define the global `` SVG tag. +data Text = Text + { -- | Define the `lengthAdjust` attribute. + _textAdjust :: !TextAdjust + -- | Root of the text content. + , _textRoot :: !TextSpan + } + deriving (Eq, Show) + +-- makeClassy ''Text +-- | Lenses for the Text type. +class HasText c_aorD where + text :: Lens' c_aorD Text + textAdjust :: Lens' c_aorD TextAdjust + {-# INLINE textAdjust #-} + textRoot :: Lens' c_aorD TextSpan + {-# INLINE textRoot #-} + textAdjust = ((.) text) textAdjust + textRoot = ((.) text) textRoot +instance HasText Text where + {-# INLINE textAdjust #-} + {-# INLINE textRoot #-} + text = id + textAdjust f attr = + fmap (\y -> attr { _textAdjust = y }) (f $ _textAdjust attr) + textRoot f attr = + fmap (\y -> attr { _textRoot = y }) (f $ _textRoot attr) + +-- | 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) + | DefinitionTree !(Definitions Tree) + | PathTree !Path + | CircleTree !Circle + | PolyLineTree !PolyLine + | PolygonTree !Polygon + | EllipseTree !Ellipse + | LineTree !Line + | RectangleTree !Rectangle + | TextTree !(Maybe TextPath) !Text + | ImageTree !Image + | LinearGradientTree !LinearGradient + | RadialGradientTree !RadialGradient + | MeshGradientTree !MeshGradient + | PatternTree !Pattern + | MarkerTree !Marker + | MaskTree !Mask + | ClipPathTree !ClipPath + deriving (Eq, Show) + +-- | Define the orientation, associated to the +-- `orient` attribute on the Marker +data MarkerOrientation + = OrientationAuto -- ^ Auto value + | OrientationAngle Coord -- ^ Specific angle. + deriving (Eq, Show) + +-- | Define the content of the `markerUnits` attribute +-- on the Marker. +data MarkerUnit + = MarkerUnitStrokeWidth -- ^ Value `strokeWidth` + | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse` + deriving (Eq, Show) + +-- | Define the content of the `markerUnits` attribute +-- on the Marker. +data Overflow + = OverflowVisible -- ^ Value `visible` + | OverflowHidden -- ^ Value `hidden` + deriving (Eq, Show) + +-- | Define the `` tag. +data Marker = Marker + { -- | Draw attributes of the marker. + _markerDrawAttributes :: DrawAttributes + -- | Define the reference point of the marker. + -- correspond to the `refX` and `refY` attributes. + , _markerRefPoint :: !(Number, Number) + -- | Define the width of the marker. Correspond to + -- the `markerWidth` attribute. + , _markerWidth :: !(Maybe Number) + -- | Define the height of the marker. Correspond to + -- the `markerHeight` attribute. + , _markerHeight :: !(Maybe Number) + -- | Correspond to the `orient` attribute. + , _markerOrient :: !(Maybe MarkerOrientation) + -- | Map the `markerUnits` attribute. + , _markerUnits :: !(Maybe MarkerUnit) + -- | Optional viewbox + , _markerViewBox :: !(Maybe (Double, Double, Double, Double)) + -- | Elements defining the marker. + , _markerOverflow :: !(Maybe Overflow) + -- | preserveAspectRatio attribute + , _markerAspectRatio :: !PreserveAspectRatio + -- | Elements defining the marker. + , _markerElements :: [Tree] + } + deriving (Eq, Show) + +-- makeClassy ''Marker +-- | Lenses for the Marker type. +class HasMarker c_aoKc where + marker :: Lens' c_aoKc Marker + markerAspectRatio :: Lens' c_aoKc PreserveAspectRatio + {-# INLINE markerAspectRatio #-} + markerDrawAttributes :: Lens' c_aoKc DrawAttributes + {-# INLINE markerDrawAttributes #-} + markerElements :: Lens' c_aoKc [Tree] + {-# INLINE markerElements #-} + markerHeight :: Lens' c_aoKc (Maybe Number) + {-# INLINE markerHeight #-} + markerOrient :: Lens' c_aoKc (Maybe MarkerOrientation) + {-# INLINE markerOrient #-} + markerOverflow :: Lens' c_aoKc (Maybe Overflow) + {-# INLINE markerOverflow #-} + markerRefPoint :: Lens' c_aoKc (Number, Number) + {-# INLINE markerRefPoint #-} + markerUnits :: Lens' c_aoKc (Maybe MarkerUnit) + {-# INLINE markerUnits #-} + markerViewBox :: + Lens' c_aoKc (Maybe (Double, Double, Double, Double)) + {-# INLINE markerViewBox #-} + markerWidth :: Lens' c_aoKc (Maybe Number) + {-# INLINE markerWidth #-} + markerAspectRatio = ((.) marker) markerAspectRatio + markerDrawAttributes = ((.) marker) markerDrawAttributes + markerElements = ((.) marker) markerElements + markerHeight = ((.) marker) markerHeight + markerOrient = ((.) marker) markerOrient + markerOverflow = ((.) marker) markerOverflow + markerRefPoint = ((.) marker) markerRefPoint + markerUnits = ((.) marker) markerUnits + markerViewBox = ((.) marker) markerViewBox + markerWidth = ((.) marker) markerWidth +instance HasMarker Marker where + {-# INLINE markerAspectRatio #-} + {-# INLINE markerDrawAttributes #-} + {-# INLINE markerElements #-} + {-# INLINE markerHeight #-} + {-# INLINE markerOrient #-} + {-# INLINE markerOverflow #-} + {-# INLINE markerRefPoint #-} + {-# INLINE markerUnits #-} + {-# INLINE markerViewBox #-} + {-# INLINE markerWidth #-} + marker = id + markerAspectRatio f attr = + fmap (\y -> attr { _markerAspectRatio = y }) (f $ _markerAspectRatio attr) + markerDrawAttributes f attr = + fmap (\y -> attr { _markerDrawAttributes = y }) (f $ _markerDrawAttributes attr) + markerElements f attr = + fmap (\y -> attr { _markerElements = y }) (f $ _markerElements attr) + markerHeight f attr = + fmap (\y -> attr { _markerHeight = y }) (f $ _markerHeight attr) + markerOrient f attr = + fmap (\y -> attr { _markerOrient = y }) (f $ _markerOrient attr) + markerOverflow f attr = + fmap (\y -> attr { _markerOverflow = y }) (f $ _markerOverflow attr) + markerRefPoint f attr = + fmap (\y -> attr { _markerRefPoint = y }) (f $ _markerRefPoint attr) + markerUnits f attr = + fmap (\y -> attr { _markerUnits = y }) (f $ _markerUnits attr) + markerViewBox f attr = + fmap (\y -> attr { _markerViewBox = y }) (f $ _markerViewBox attr) + markerWidth f attr = + fmap (\y -> attr { _markerWidth = y }) (f $ _markerWidth attr) + +instance WithDrawAttributes Marker where + drawAttr = markerDrawAttributes + +instance WithDefaultSvg Marker where + defaultSvg = Marker + { _markerDrawAttributes = mempty + , _markerRefPoint = (Num 0, Num 0) + , _markerWidth = Just (Num 3) + , _markerHeight = Just (Num 3) + , _markerOrient = Nothing -- MarkerOrientation + , _markerUnits = Nothing -- MarkerUnitStrokeWidth + , _markerViewBox = Nothing + , _markerOverflow = Nothing + , _markerElements = mempty + , _markerAspectRatio = defaultSvg + } + +-- | Insert element in the first sublist in the list of list. +appNode :: [[a]] -> a -> [[a]] +appNode [] e = [[e]] +appNode (curr:above) e = (e:curr) : above + +-- | Map a tree while propagating context information. +-- The function passed in parameter receive a list +-- representing the the path used to go arrive to the +-- current node. +zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree +zipTree f = dig [] where + dig prev e@None = f $ appNode prev e + dig prev e@(UseTree _ Nothing) = f $ appNode prev e + dig prev e@(UseTree nfo (Just u)) = + f . appNode prev . UseTree nfo . Just $ dig ([] : appNode prev e) u + dig prev e@(GroupTree g) = + f . appNode prev . GroupTree $ zipGroup (appNode prev e) g + dig prev e@(SymbolTree g) = + f . appNode prev . SymbolTree . Symbol . + zipGroup (appNode prev e) $ _groupOfSymbol g + dig prev e@(PathTree _) = f $ appNode prev e + dig prev e@(CircleTree _) = f $ appNode prev e + dig prev e@(PolyLineTree _) = f $ appNode prev e + dig prev e@(PolygonTree _) = f $ appNode prev e + dig prev e@(EllipseTree _) = f $ appNode prev e + dig prev e@(LineTree _) = f $ appNode prev e + dig prev e@(RectangleTree _) = f $ appNode prev e + dig prev e@(TextTree _ _) = f $ appNode prev e + dig prev e@(ImageTree _) = f $ appNode prev e + dig prev e@(MeshGradientTree _) = f $ appNode prev e + dig prev e@(DefinitionTree _) = f $ appNode prev e + dig prev e@(LinearGradientTree _) = f $ appNode prev e + dig prev e@(RadialGradientTree _) = f $ appNode prev e + dig prev e@(PatternTree _) = f $ appNode prev e + dig prev e@(MarkerTree _) = f $ appNode prev e + dig prev e@(MaskTree _) = f $ appNode prev e + dig prev e@(ClipPathTree _) = 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 + LinearGradientTree _ -> f acc e + RadialGradientTree _ -> f acc e + MeshGradientTree _ -> f acc e + PatternTree _ -> f acc e + MarkerTree _ -> f acc e + MaskTree _ -> f acc e + ClipPathTree _ -> f acc e + DefinitionTree d -> + let subAcc = + F.foldl' go acc . _groupChildren $ _groupOfDefinitions d in + f subAcc 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 (DefinitionTree defs) = + f . DefinitionTree . Definitions . mapGroup $ _groupOfDefinitions defs + 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 + go e@(LinearGradientTree _) = f e + go e@(RadialGradientTree _) = f e + go e@(MeshGradientTree _) = f e + go e@(PatternTree _) = f e + go e@(MarkerTree _) = f e + go e@(MaskTree _) = f e + go e@(ClipPathTree _) = 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" + DefinitionTree _ -> "defs" + PathTree _ -> "path" + CircleTree _ -> "circle" + PolyLineTree _ -> "polyline" + PolygonTree _ -> "polygon" + EllipseTree _ -> "ellipse" + LineTree _ -> "line" + RectangleTree _ -> "rectangle" + TextTree _ _ -> "text" + ImageTree _ -> "image" + LinearGradientTree _ -> "lineargradient" + RadialGradientTree _ -> "radialgradient" + MeshGradientTree _ -> "meshgradient" + PatternTree _ -> "pattern" + MarkerTree _ -> "marker" + MaskTree _ -> "mask" + ClipPathTree _ -> "clipPath" + +drawAttrOfTree :: Tree -> DrawAttributes +drawAttrOfTree v = case v of + None -> mempty + UseTree e _ -> e ^. drawAttr + GroupTree e -> e ^. drawAttr + SymbolTree e -> e ^. drawAttr + DefinitionTree 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 + LinearGradientTree e -> e ^. drawAttr + RadialGradientTree e -> e ^. drawAttr + MeshGradientTree e -> e ^. drawAttr + PatternTree e -> e ^. drawAttr + MarkerTree e -> e ^. drawAttr + MaskTree e -> e ^. drawAttr + ClipPathTree 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 + DefinitionTree e -> DefinitionTree e + 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 + LinearGradientTree e -> LinearGradientTree $ e & drawAttr .~ attr + RadialGradientTree e -> RadialGradientTree $ e & drawAttr .~ attr + MeshGradientTree e -> MeshGradientTree $ e & drawAttr .~ attr + PatternTree e -> PatternTree $ e & drawAttr .~ attr + MarkerTree e -> MarkerTree $ e & drawAttr .~ attr + MaskTree e -> MaskTree $ e & drawAttr .~ attr + ClipPathTree e -> ClipPathTree $ e & drawAttr .~ attr + +instance WithDrawAttributes Tree where + drawAttr = lens drawAttrOfTree setDrawAttrOfTree + +instance WithDefaultSvg Tree where + defaultSvg = None + +-- | 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 `` tag. +data LinearGradient = LinearGradient + { -- | Drawing attributes of the RadialGradient + _linearGradientDrawAttributes :: DrawAttributes + -- | 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) + +-- makeClassy ''LinearGradient +-- | Lenses for the LinearGradient type. +class HasLinearGradient c_apmJ where + linearGradient :: Lens' c_apmJ LinearGradient + linearGradientDrawAttributes :: Lens' c_apmJ DrawAttributes + linearGradientSpread :: Lens' c_apmJ Spread + {-# INLINE linearGradientSpread #-} + linearGradientStart :: Lens' c_apmJ Point + {-# INLINE linearGradientStart #-} + linearGradientStop :: Lens' c_apmJ Point + {-# INLINE linearGradientStop #-} + linearGradientStops :: Lens' c_apmJ [GradientStop] + {-# INLINE linearGradientStops #-} + linearGradientTransform :: Lens' c_apmJ [Transformation] + {-# INLINE linearGradientTransform #-} + linearGradientUnits :: Lens' c_apmJ CoordinateUnits + {-# INLINE linearGradientUnits #-} + linearGradientDrawAttributes = ((.) linearGradient) linearGradientDrawAttributes + linearGradientSpread = ((.) linearGradient) linearGradientSpread + linearGradientStart = ((.) linearGradient) linearGradientStart + linearGradientStop = ((.) linearGradient) linearGradientStop + linearGradientStops = ((.) linearGradient) linearGradientStops + linearGradientTransform + = ((.) linearGradient) linearGradientTransform + linearGradientUnits = ((.) linearGradient) linearGradientUnits + +instance HasLinearGradient LinearGradient where + {-# INLINE linearGradientSpread #-} + {-# INLINE linearGradientStart #-} + {-# INLINE linearGradientStop #-} + {-# INLINE linearGradientStops #-} + {-# INLINE linearGradientTransform #-} + {-# INLINE linearGradientUnits #-} + linearGradient = id + linearGradientSpread f attr = + fmap (\y -> attr { _linearGradientSpread = y }) (f $ _linearGradientSpread attr) + linearGradientStart f attr = + fmap (\y -> attr { _linearGradientStart = y }) (f $ _linearGradientStart attr) + linearGradientStop f attr = + fmap (\y -> attr { _linearGradientStop = y }) (f $ _linearGradientStop attr) + linearGradientStops f attr = + fmap (\y -> attr { _linearGradientStops = y }) (f $ _linearGradientStops attr) + linearGradientTransform f attr = + fmap (\y -> attr { _linearGradientTransform = y }) (f $ _linearGradientTransform attr) + linearGradientUnits f attr = + fmap (\y -> attr { _linearGradientUnits = y }) (f $ _linearGradientUnits attr) + +instance WithDrawAttributes LinearGradient where + drawAttr = linearGradientDrawAttributes + +instance WithDefaultSvg LinearGradient where + defaultSvg = LinearGradient + { _linearGradientDrawAttributes = mempty + , _linearGradientUnits = CoordBoundingBox + , _linearGradientStart = (Percent 0, Percent 0) + , _linearGradientStop = (Percent 1, Percent 0) + , _linearGradientSpread = SpreadPad + , _linearGradientTransform = [] + , _linearGradientStops = [] + } + +-- | Define a `` tag. +data RadialGradient = RadialGradient + { -- | Drawing attributes of the RadialGradient + _radialGradientDrawAttributes :: DrawAttributes + -- | 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) + +-- makeClassy ''RadialGradient +-- | Lenses for the RadialGradient type. + +class HasRadialGradient c_apwt where + radialGradient :: Lens' c_apwt RadialGradient + radialGradientDrawAttributes :: Lens' c_apwt DrawAttributes + radialGradientCenter :: Lens' c_apwt Point + {-# INLINE radialGradientCenter #-} + radialGradientFocusX :: Lens' c_apwt (Maybe Number) + {-# INLINE radialGradientFocusX #-} + radialGradientFocusY :: Lens' c_apwt (Maybe Number) + {-# INLINE radialGradientFocusY #-} + radialGradientRadius :: Lens' c_apwt Number + {-# INLINE radialGradientRadius #-} + radialGradientSpread :: Lens' c_apwt Spread + {-# INLINE radialGradientSpread #-} + radialGradientStops :: Lens' c_apwt [GradientStop] + {-# INLINE radialGradientStops #-} + radialGradientTransform :: Lens' c_apwt [Transformation] + {-# INLINE radialGradientTransform #-} + radialGradientUnits :: Lens' c_apwt CoordinateUnits + {-# INLINE radialGradientUnits #-} + radialGradientDrawAttributes = ((.) radialGradient) radialGradientDrawAttributes + radialGradientCenter = ((.) radialGradient) radialGradientCenter + radialGradientFocusX = ((.) radialGradient) radialGradientFocusX + radialGradientFocusY = ((.) radialGradient) radialGradientFocusY + radialGradientRadius = ((.) radialGradient) radialGradientRadius + radialGradientSpread = ((.) radialGradient) radialGradientSpread + radialGradientStops = ((.) radialGradient) radialGradientStops + radialGradientTransform + = ((.) radialGradient) radialGradientTransform + radialGradientUnits = ((.) radialGradient) radialGradientUnits + +instance HasRadialGradient RadialGradient where + {-# INLINE radialGradientCenter #-} + {-# INLINE radialGradientFocusX #-} + {-# INLINE radialGradientFocusY #-} + {-# INLINE radialGradientRadius #-} + {-# INLINE radialGradientSpread #-} + {-# INLINE radialGradientStops #-} + {-# INLINE radialGradientTransform #-} + {-# INLINE radialGradientUnits #-} + radialGradient = id + radialGradientCenter f attr = + fmap (\y -> attr { _radialGradientCenter = y }) (f $ _radialGradientCenter attr) + radialGradientFocusX f attr = + fmap (\y -> attr { _radialGradientFocusX = y }) (f $ _radialGradientFocusX attr) + radialGradientFocusY f attr = + fmap (\y -> attr { _radialGradientFocusY = y }) (f $ _radialGradientFocusY attr) + radialGradientRadius f attr = + fmap (\y -> attr { _radialGradientRadius = y }) (f $ _radialGradientRadius attr) + radialGradientSpread f attr = + fmap (\y -> attr { _radialGradientSpread = y }) (f $ _radialGradientSpread attr) + radialGradientStops f attr = + fmap (\y -> attr { _radialGradientStops = y }) (f $ _radialGradientStops attr) + radialGradientTransform f attr = + fmap (\y -> attr { _radialGradientTransform = y }) (f $ _radialGradientTransform attr) + radialGradientUnits f attr = + fmap (\y -> attr { _radialGradientUnits = y }) (f $ _radialGradientUnits attr) + +instance WithDrawAttributes RadialGradient where + drawAttr = radialGradientDrawAttributes + +instance WithDefaultSvg RadialGradient where + defaultSvg = RadialGradient + { _radialGradientDrawAttributes = mempty + , _radialGradientUnits = CoordBoundingBox + , _radialGradientCenter = (Percent 0.5, Percent 0.5) + , _radialGradientRadius = Percent 0.5 + , _radialGradientFocusX = Nothing + , _radialGradientFocusY = Nothing + , _radialGradientSpread = SpreadPad + , _radialGradientTransform = [] + , _radialGradientStops = [] + } + +-- | Define a SVG `` tag. +data Mask = Mask + { -- | Drawing attributes of the Mask + _maskDrawAttributes :: DrawAttributes + -- | Correspond to the `maskContentUnits` attributes. + , _maskContentUnits :: CoordinateUnits + -- | Mapping to the `maskUnits` attribute. + , _maskUnits :: CoordinateUnits + -- | Map to the `x` and `y` attributes. + , _maskPosition :: Point + -- | Map to the `width` attribute + , _maskWidth :: Number + -- | Map to the `height` attribute. + , _maskHeight :: Number + -- | Children of the `` tag. + , _maskContent :: [Tree] + } + deriving (Eq, Show) + +-- makeClassy ''Mask +-- | Lenses for the Mask type. +class HasMask c_apHI where + mask :: Lens' c_apHI Mask + maskContent :: Lens' c_apHI [Tree] + {-# INLINE maskContent #-} + maskContentUnits :: Lens' c_apHI CoordinateUnits + {-# INLINE maskContentUnits #-} + maskDrawAttributes :: Lens' c_apHI DrawAttributes + {-# INLINE maskDrawAttributes #-} + maskHeight :: Lens' c_apHI Number + {-# INLINE maskHeight #-} + maskPosition :: Lens' c_apHI Point + {-# INLINE maskPosition #-} + maskUnits :: Lens' c_apHI CoordinateUnits + {-# INLINE maskUnits #-} + maskWidth :: Lens' c_apHI Number + {-# INLINE maskWidth #-} + maskContent = ((.) mask) maskContent + maskContentUnits = ((.) mask) maskContentUnits + maskDrawAttributes = ((.) mask) maskDrawAttributes + maskHeight = ((.) mask) maskHeight + maskPosition = ((.) mask) maskPosition + maskUnits = ((.) mask) maskUnits + maskWidth = ((.) mask) maskWidth + +instance HasMask Mask where + {-# INLINE maskContent #-} + {-# INLINE maskContentUnits #-} + {-# INLINE maskDrawAttributes #-} + {-# INLINE maskHeight #-} + {-# INLINE maskPosition #-} + {-# INLINE maskUnits #-} + {-# INLINE maskWidth #-} + mask = id + maskContent f attr = + fmap (\y -> attr { _maskContent = y }) (f $ _maskContent attr) + maskContentUnits f attr = + fmap (\y -> attr { _maskContentUnits = y }) (f $ _maskContentUnits attr) + maskDrawAttributes f attr = + fmap (\y -> attr { _maskDrawAttributes = y }) (f $ _maskDrawAttributes attr) + maskHeight f attr = + fmap (\y -> attr { _maskHeight = y }) (f $ _maskHeight attr) + maskPosition f attr = + fmap (\y -> attr { _maskPosition = y }) (f $ _maskPosition attr) + maskUnits f attr = + fmap (\y -> attr { _maskUnits = y }) (f $ _maskUnits attr) + maskWidth f attr = + fmap (\y -> attr { _maskWidth = y }) (f $ _maskWidth attr) + +instance WithDrawAttributes Mask where + drawAttr = maskDrawAttributes + +instance WithDefaultSvg Mask where + defaultSvg = Mask + { _maskDrawAttributes = mempty + , _maskContentUnits = CoordUserSpace + , _maskUnits = CoordBoundingBox + , _maskPosition = (Percent (-0.1), Percent (-0.1)) + , _maskWidth = Percent 1.2 + , _maskHeight = Percent 1.2 + , _maskContent = [] + } + +-- | Define a `` tag. +data ClipPath = ClipPath + { _clipPathDrawAttributes :: DrawAttributes + -- | Maps to the `clipPathUnits` attribute + , _clipPathUnits :: CoordinateUnits + -- | Maps to the content of the tree + , _clipPathContent :: [Tree] + } + deriving (Eq, Show) + +-- makeClassy ''ClipPath +-- | Lenses for the ClipPath type. +class HasClipPath c_apZq where + clipPath :: Lens' c_apZq ClipPath + clipPathContent :: Lens' c_apZq [Tree] + {-# INLINE clipPathContent #-} + clipPathDrawAttributes :: Lens' c_apZq DrawAttributes + {-# INLINE clipPathDrawAttributes #-} + clipPathUnits :: Lens' c_apZq CoordinateUnits + {-# INLINE clipPathUnits #-} + clipPathContent = ((.) clipPath) clipPathContent + clipPathDrawAttributes = ((.) clipPath) clipPathDrawAttributes + clipPathUnits = ((.) clipPath) clipPathUnits +instance HasClipPath ClipPath where + {-# INLINE clipPathContent #-} + {-# INLINE clipPathDrawAttributes #-} + {-# INLINE clipPathUnits #-} + clipPath = id + clipPathContent f attr = + fmap (\y -> attr { _clipPathContent = y }) (f $ _clipPathContent attr) + clipPathDrawAttributes f attr = + fmap (\y -> attr { _clipPathDrawAttributes = y }) (f $ _clipPathDrawAttributes attr) + clipPathUnits f attr = + fmap (\y -> attr { _clipPathUnits = y }) (f $ _clipPathUnits attr) + +instance WithDrawAttributes ClipPath where + drawAttr = clipPathDrawAttributes + +instance WithDefaultSvg ClipPath where + defaultSvg = ClipPath + { _clipPathDrawAttributes = mempty + , _clipPathUnits = CoordUserSpace + , _clipPathContent = mempty + } + +-- | Define a `` tag. +data Pattern = Pattern + { -- | Pattern drawing attributes. + _patternDrawAttributes :: !DrawAttributes + -- | Possible `viewBox`. + , _patternViewBox :: !(Maybe (Double, Double, Double, Double)) + -- | Width of the pattern tile, mapped to the + -- `width` attribute + , _patternWidth :: !Number + -- | Height of the pattern tile, mapped to the + -- `height` attribute + , _patternHeight :: !Number + -- | Pattern tile base, mapped to the `x` and + -- `y` attributes. + , _patternPos :: !Point + -- | Patterns can be chained, so this is a potential + -- reference to another pattern + , _patternHref :: !String + -- | Elements used in the pattern. + , _patternElements :: ![Tree] + -- | Define the cordinate system to use for + -- the pattern. Mapped to the `patternUnits` + -- attribute. + , _patternUnit :: !CoordinateUnits + -- | Value of the "preserveAspectRatio" attribute + , _patternAspectRatio :: !PreserveAspectRatio + -- | Value of "patternTransform" attribute + , _patternTransform :: !(Maybe [Transformation]) + } + deriving (Eq, Show) + +-- makeClassy ''Pattern +-- | Lenses for the Patter type. +class HasPattern c_aq6G where + pattern :: Lens' c_aq6G Pattern + patternAspectRatio :: Lens' c_aq6G PreserveAspectRatio + {-# INLINE patternAspectRatio #-} + patternDrawAttributes :: Lens' c_aq6G DrawAttributes + {-# INLINE patternDrawAttributes #-} + patternElements :: Lens' c_aq6G [Tree] + {-# INLINE patternElements #-} + patternHeight :: Lens' c_aq6G Number + {-# INLINE patternHeight #-} + patternHref :: Lens' c_aq6G String + {-# INLINE patternHref #-} + patternPos :: Lens' c_aq6G Point + {-# INLINE patternPos #-} + patternTransform :: Lens' c_aq6G (Maybe [Transformation]) + {-# INLINE patternTransform #-} + patternUnit :: Lens' c_aq6G CoordinateUnits + {-# INLINE patternUnit #-} + patternViewBox :: + Lens' c_aq6G (Maybe (Double, Double, Double, Double)) + {-# INLINE patternViewBox #-} + patternWidth :: Lens' c_aq6G Number + {-# INLINE patternWidth #-} + patternAspectRatio = ((.) pattern) patternAspectRatio + patternDrawAttributes = ((.) pattern) patternDrawAttributes + patternElements = ((.) pattern) patternElements + patternHeight = ((.) pattern) patternHeight + patternHref = ((.) pattern) patternHref + patternPos = ((.) pattern) patternPos + patternTransform = ((.) pattern) patternTransform + patternUnit = ((.) pattern) patternUnit + patternViewBox = ((.) pattern) patternViewBox + patternWidth = ((.) pattern) patternWidth + +instance HasPattern Pattern where + {-# INLINE patternAspectRatio #-} + {-# INLINE patternDrawAttributes #-} + {-# INLINE patternElements #-} + {-# INLINE patternHeight #-} + {-# INLINE patternHref #-} + {-# INLINE patternPos #-} + {-# INLINE patternTransform #-} + {-# INLINE patternUnit #-} + {-# INLINE patternViewBox #-} + {-# INLINE patternWidth #-} + pattern = id + patternAspectRatio f attr = + fmap (\y -> attr { _patternAspectRatio = y }) (f $ _patternAspectRatio attr) + patternDrawAttributes f attr = + fmap (\y -> attr { _patternDrawAttributes = y }) (f $ _patternDrawAttributes attr) + patternElements f attr = + fmap (\y -> attr { _patternElements = y }) (f $ _patternElements attr) + patternHeight f attr = + fmap (\y -> attr { _patternHeight = y }) (f $ _patternHeight attr) + patternHref f attr = + fmap (\y -> attr { _patternHref = y }) (f $ _patternHref attr) + patternPos f attr = + fmap (\y -> attr { _patternPos = y }) (f $ _patternPos attr) + patternTransform f attr = + fmap (\y -> attr { _patternTransform = y }) (f $ _patternTransform attr) + patternUnit f attr = + fmap (\y -> attr { _patternUnit = y }) (f $ _patternUnit attr) + patternViewBox f attr = + fmap (\y -> attr { _patternViewBox = y }) (f $ _patternViewBox attr) + patternWidth f attr = + fmap (\y -> attr { _patternWidth = y }) (f $ _patternWidth attr) + +instance WithDrawAttributes Pattern where + drawAttr = patternDrawAttributes + +instance WithDefaultSvg Pattern where + defaultSvg = Pattern + { _patternViewBox = Nothing + , _patternWidth = Num 0 + , _patternHeight = Num 0 + , _patternPos = (Num 0, Num 0) + , _patternElements = [] + , _patternUnit = CoordBoundingBox + , _patternDrawAttributes = mempty + , _patternAspectRatio = defaultSvg + , _patternHref = "" + , _patternTransform = mempty + } + +-- | Sum types helping keeping track of all the namable +-- elemens in a SVG document. +data Element + = ElementLinearGradient LinearGradient + | ElementRadialGradient RadialGradient + | ElementMeshGradient MeshGradient + | ElementGeometry Tree + | ElementPattern Pattern + | ElementMarker Marker + | ElementMask Mask + | ElementClipPath ClipPath + deriving (Eq, Show) + +-- | Represent a full svg document with style, +-- geometry and named elements. +data Document = Document + { _viewBox :: Maybe (Double, Double, Double, Double) + , _width :: Maybe Number + , _height :: Maybe Number + , _elements :: [Tree] + , _definitions :: M.Map String Tree + , _description :: String + , _styleRules :: [CssRule] + , _documentLocation :: FilePath + } + deriving Show + +-- makeClassy ''Document +-- | Lenses associated to a SVG document. +class HasDocument c_aqpq where + document :: Lens' c_aqpq Document + definitions :: Lens' c_aqpq (M.Map String Tree) + {-# INLINE definitions #-} + definitions = document . definitions + + description :: Lens' c_aqpq String + {-# INLINE description #-} + description = document . description + + documentLocation :: Lens' c_aqpq FilePath + {-# INLINE documentLocation #-} + documentLocation = document . documentLocation + + elements :: Lens' c_aqpq [Tree] + {-# INLINE elements #-} + elements = document . elements + + height :: Lens' c_aqpq (Maybe Number) + {-# INLINE height #-} + height = document . height + + styleRules :: Lens' c_aqpq [CssRule] + {-# INLINE styleRules #-} + styleRules = document . styleRules + + viewBox :: Lens' c_aqpq (Maybe (Double, Double, Double, Double)) + {-# INLINE viewBox #-} + viewBox = document . viewBox + + width :: Lens' c_aqpq (Maybe Number) + {-# INLINE width #-} + width = document . width + +instance HasDocument Document where + document = id + {-# INLINE definitions #-} + definitions f attr = + fmap (\y -> attr { _definitions = y }) (f $ _definitions attr) + + {-# INLINE description #-} + description f attr = + fmap (\y -> attr { _description = y }) (f $ _description attr) + + {-# INLINE documentLocation #-} + documentLocation f attr = + fmap (\y -> attr { _documentLocation = y }) (f $ _documentLocation attr) + + {-# INLINE elements #-} + elements f attr = + fmap (\y -> attr { _elements = y }) (f $ _elements attr) + + {-# INLINE height #-} + height f attr = + fmap (\y -> attr { _height = y }) (f $ _height attr) + + {-# INLINE styleRules #-} + styleRules f attr = + fmap (\y -> attr { _styleRules = y }) (f $ _styleRules attr) + + {-# INLINE viewBox #-} + viewBox f attr = + fmap (\y -> attr { _viewBox = y }) (f $ _viewBox attr) + + {-# INLINE width #-} + width f attr = + fmap (\y -> attr { _width = y }) (f $ _width attr) + +-- | Calculate the document size in function of the +-- different available attributes in the document. +documentSize :: Dpi -> Document -> (Int, Int) +documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) + , _width = Just (Percent pw) + , _height = Just (Percent ph) + } = + (floor $ dx * pw, floor $ dy * ph) + where + dx = abs $ x2 - x1 + dy = abs $ y2 - y1 +documentSize _ Document { _width = Just (Num w) + , _height = Just (Num h) } = (floor w, floor h) +documentSize dpi doc@(Document { _width = Just w + , _height = Just h }) = + documentSize dpi $ doc + { _width = Just $ toUserUnit dpi w + , _height = Just $ toUserUnit dpi h } +documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } = + (floor . abs $ x2 - x1, floor . abs $ y2 - y1) +documentSize _ _ = (1, 1) + +mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a +mayMerge (Just a) (Just b) = Just $ mappend a b +mayMerge _ b@(Just _) = b +mayMerge a Nothing = a + +instance Semigroup DrawAttributes where + (<>) a b = DrawAttributes + { _strokeWidth = (mappend `on` _strokeWidth) a b + , _strokeColor = (mappend `on` _strokeColor) a b + , _strokeLineCap = (mappend `on` _strokeLineCap) a b + , _strokeOpacity = (opacityMappend `on` _strokeOpacity) a b + , _strokeLineJoin = (mappend `on` _strokeLineJoin) a b + , _strokeMiterLimit = (mappend `on` _strokeMiterLimit) a b + , _fillColor = (mappend `on` _fillColor) a b + , _fillOpacity = (opacityMappend `on` _fillOpacity) a b + , _fontSize = (mappend `on` _fontSize) a b + , _transform = (mayMerge `on` _transform) a b + , _fillRule = (mappend `on` _fillRule) a b + , _attrClass = _attrClass b + , _attrId = _attrId b + , _groupOpacity = _groupOpacity b + , _strokeOffset = (mappend `on` _strokeOffset) a b + , _strokeDashArray = (mappend `on` _strokeDashArray) a b + , _fontFamily = (mappend `on` _fontFamily) a b + , _fontStyle = (mappend `on` _fontStyle) a b + , _textAnchor = (mappend `on` _textAnchor) a b + , _maskRef = (mappend `on` _maskRef) a b + , _clipPathRef = (mappend `on` _clipPathRef) a b + , _clipRule = (mappend `on` _clipRule) a b + , _markerStart = (mappend `on` _markerStart) a b + , _markerMid = (mappend `on` _markerMid) a b + , _markerEnd = (mappend `on` _markerEnd) a b + } + where + opacityMappend Nothing Nothing = Nothing + opacityMappend (Just v) Nothing = Just v + opacityMappend Nothing (Just v) = Just v + opacityMappend (Just v) (Just v2) = Just $ v * v2 + +instance Monoid DrawAttributes where + mappend = (<>) + mempty = DrawAttributes + { _strokeWidth = Last Nothing + , _strokeColor = Last Nothing + , _strokeOpacity = Nothing + , _strokeLineCap = Last Nothing + , _strokeLineJoin = Last Nothing + , _strokeMiterLimit = Last Nothing + , _fillColor = Last Nothing + , _groupOpacity = Nothing + , _fillOpacity = Nothing + , _fontSize = Last Nothing + , _fontFamily = Last Nothing + , _fontStyle = Last Nothing + , _transform = Nothing + , _fillRule = Last Nothing + , _attrClass = mempty + , _attrId = Nothing + , _strokeOffset = Last Nothing + , _strokeDashArray = Last Nothing + , _textAnchor = Last Nothing + , _maskRef = Last Nothing + , _clipPathRef = Last Nothing + , _clipRule = Last Nothing + + , _markerStart = Last Nothing + , _markerMid = Last Nothing + , _markerEnd = Last Nothing + } + +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 + +-------------------------------------------------------------------------- +--- Dumped +-------------------------------------------------------------------------- +-- makeClassy ''PreserveAspectRatio +-- +-- | Lenses for the PreserveAspectRatio type +class HasPreserveAspectRatio a where + preserveAspectRatio :: Lens' a PreserveAspectRatio + aspectRatioAlign :: Lens' a Alignment + {-# INLINE aspectRatioAlign #-} + aspectRatioAlign = preserveAspectRatio . aspectRatioAlign + + aspectRatioDefer :: Lens' a Bool + {-# INLINE aspectRatioDefer #-} + aspectRatioDefer = preserveAspectRatio . aspectRatioDefer + + aspectRatioMeetSlice :: Lens' a (Maybe MeetSlice) + {-# INLINE aspectRatioMeetSlice #-} + aspectRatioMeetSlice = preserveAspectRatio . aspectRatioMeetSlice + +instance HasPreserveAspectRatio PreserveAspectRatio where + preserveAspectRatio = id + {-# INLINE aspectRatioAlign #-} + aspectRatioAlign f attr = + fmap (\y -> attr { _aspectRatioAlign = y }) (f $ _aspectRatioAlign attr) + + {-# INLINE aspectRatioDefer #-} + aspectRatioDefer f attr = + fmap (\y -> attr { _aspectRatioDefer = y }) (f $ _aspectRatioDefer attr) + + {-# INLINE aspectRatioMeetSlice #-} + aspectRatioMeetSlice f attr = + fmap (\y -> attr { _aspectRatioMeetSlice = y }) (f $ _aspectRatioMeetSlice attr) + +-- makeClassy ''DrawAttributes +-- | Lenses for the DrawAttributes type. +class HasDrawAttributes a where + drawAttributes :: Lens' a DrawAttributes + attrClass :: Lens' a [T.Text] + {-# INLINE attrClass #-} + attrClass = drawAttributes . attrClass + + attrId :: Lens' a (Maybe String) + {-# INLINE attrId #-} + attrId = drawAttributes . attrId + + clipPathRef :: Lens' a (Last ElementRef) + {-# INLINE clipPathRef #-} + clipPathRef = drawAttributes . clipPathRef + + clipRule :: Lens' a (Last FillRule) + {-# INLINE clipRule #-} + clipRule = drawAttributes . clipRule + + fillColor :: Lens' a (Last Texture) + {-# INLINE fillColor #-} + fillColor = drawAttributes . fillColor + + fillOpacity :: Lens' a (Maybe Float) + {-# INLINE fillOpacity #-} + fillOpacity = drawAttributes . fillOpacity + + fillRule :: Lens' a (Last FillRule) + {-# INLINE fillRule #-} + fillRule = drawAttributes . fillRule + + fontFamily :: Lens' a (Last [String]) + {-# INLINE fontFamily #-} + fontFamily = drawAttributes . fontFamily + + fontSize :: Lens' a (Last Number) + {-# INLINE fontSize #-} + fontSize = drawAttributes . fontSize + + fontStyle :: Lens' a (Last FontStyle) + {-# INLINE fontStyle #-} + fontStyle = drawAttributes . fontStyle + + groupOpacity :: Lens' a (Maybe Float) + {-# INLINE groupOpacity #-} + groupOpacity = drawAttributes . groupOpacity + + markerEnd :: Lens' a (Last ElementRef) + {-# INLINE markerEnd #-} + markerEnd = drawAttributes . markerEnd + + markerMid :: Lens' a (Last ElementRef) + {-# INLINE markerMid #-} + markerMid = drawAttributes . markerMid + + markerStart :: Lens' a (Last ElementRef) + {-# INLINE markerStart #-} + markerStart = drawAttributes . markerStart + + maskRef :: Lens' a (Last ElementRef) + {-# INLINE maskRef #-} + maskRef = drawAttributes . maskRef + + strokeColor :: Lens' a (Last Texture) + {-# INLINE strokeColor #-} + strokeColor = drawAttributes . strokeColor + + strokeDashArray :: Lens' a (Last [Number]) + {-# INLINE strokeDashArray #-} + strokeDashArray = drawAttributes . strokeDashArray + + strokeLineCap :: Lens' a (Last Cap) + {-# INLINE strokeLineCap #-} + strokeLineCap = drawAttributes . strokeLineCap + + strokeLineJoin :: Lens' a (Last LineJoin) + {-# INLINE strokeLineJoin #-} + strokeLineJoin = drawAttributes . strokeLineJoin + + strokeMiterLimit :: Lens' a (Last Double) + {-# INLINE strokeMiterLimit #-} + strokeMiterLimit = drawAttributes . strokeMiterLimit + + strokeOffset :: Lens' a (Last Number) + {-# INLINE strokeOffset #-} + strokeOffset = drawAttributes . strokeOffset + + strokeOpacity :: Lens' a (Maybe Float) + {-# INLINE strokeOpacity #-} + strokeOpacity = drawAttributes . strokeOpacity + + strokeWidth :: Lens' a (Last Number) + {-# INLINE strokeWidth #-} + strokeWidth = drawAttributes . strokeWidth + + textAnchor :: Lens' a (Last TextAnchor) + {-# INLINE textAnchor #-} + textAnchor = drawAttributes . textAnchor + + transform :: Lens' a (Maybe [Transformation]) + {-# INLINE transform #-} + transform = drawAttributes . transform + +instance HasDrawAttributes DrawAttributes where + {-# INLINE attrId #-} + {-# INLINE clipPathRef #-} + {-# INLINE clipRule #-} + {-# INLINE fillColor #-} + {-# INLINE fillOpacity #-} + {-# INLINE fillRule #-} + {-# INLINE fontFamily #-} + {-# INLINE fontSize #-} + {-# INLINE fontStyle #-} + {-# INLINE groupOpacity #-} + {-# INLINE markerEnd #-} + {-# INLINE markerMid #-} + {-# INLINE markerStart #-} + {-# INLINE maskRef #-} + {-# INLINE strokeColor #-} + {-# INLINE strokeDashArray #-} + {-# INLINE strokeLineCap #-} + {-# INLINE strokeLineJoin #-} + {-# INLINE strokeMiterLimit #-} + {-# INLINE strokeOffset #-} + {-# INLINE strokeOpacity #-} + {-# INLINE strokeWidth #-} + {-# INLINE textAnchor #-} + {-# INLINE transform #-} + drawAttributes = id + + {-# INLINE attrClass #-} + attrClass f attr = + fmap (\y -> attr { _attrClass = y }) (f (_attrClass attr)) + attrId f attr = + fmap (\y -> attr { _attrId = y }) (f $ _attrId attr) + clipPathRef f attr = + fmap (\y -> attr { _clipPathRef = y }) (f $ _clipPathRef attr) + clipRule f attr = + fmap (\y -> attr { _clipRule = y }) (f $ _clipRule attr) + fillColor f attr = + fmap (\y -> attr { _fillColor = y }) (f $ _fillColor attr) + fillOpacity f attr = + fmap (\y -> attr { _fillOpacity = y }) (f $ _fillOpacity attr) + fillRule f attr = + fmap (\y -> attr { _fillRule = y }) (f $ _fillRule attr) + fontFamily f attr = + fmap (\y -> attr { _fontFamily = y }) (f $ _fontFamily attr) + fontSize f attr = + fmap (\y -> attr { _fontSize = y }) (f $ _fontSize attr) + fontStyle f attr = + fmap (\y -> attr { _fontStyle = y }) (f $ _fontStyle attr) + groupOpacity f attr = + fmap (\y -> attr { _groupOpacity = y }) (f $ _groupOpacity attr) + markerEnd f attr = + fmap (\y -> attr { _markerEnd = y }) (f $ _markerEnd attr) + markerMid f attr = + fmap (\y -> attr { _markerMid = y }) (f $ _markerMid attr) + markerStart f attr = + fmap (\y -> attr { _markerStart = y }) (f $ _markerStart attr) + maskRef f attr = + fmap (\y -> attr { _maskRef = y }) (f $ _maskRef attr) + strokeColor f attr = + fmap (\y -> attr { _strokeColor = y }) (f $ _strokeColor attr) + strokeDashArray f attr = + fmap (\y -> attr { _strokeDashArray = y }) (f $ _strokeDashArray attr) + strokeLineCap f attr = + fmap (\y -> attr { _strokeLineCap = y }) (f $ _strokeLineCap attr) + strokeLineJoin f attr = + fmap (\y -> attr { _strokeLineJoin = y }) (f $ _strokeLineJoin attr) + strokeMiterLimit f attr = + fmap (\y -> attr { _strokeMiterLimit = y }) (f $ _strokeMiterLimit attr) + strokeOffset f attr = + fmap (\y -> attr { _strokeOffset = y }) (f $ _strokeOffset attr) + strokeOpacity f attr = + fmap (\y -> attr { _strokeOpacity = y }) (f $ _strokeOpacity attr) + strokeWidth f attr = + fmap (\y -> attr { _strokeWidth = y }) (f $ _strokeWidth attr) + textAnchor f attr = + fmap (\y -> attr { _textAnchor = y }) (f $ _textAnchor attr) + transform f attr = + fmap (\y -> attr { _transform = y }) (f $ _transform attr) diff --git a/src/Graphics/SvgTree/XmlParser.hs b/src/Graphics/SvgTree/XmlParser.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SvgTree/XmlParser.hs @@ -0,0 +1,1204 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +module Graphics.SvgTree.XmlParser + ( xmlOfDocument + , unparseDocument + + , SvgAttributeLens( .. ) + , drawAttributesList + ) where + + +#if !MIN_VERSION_base(4,6,0) +import Text.Read (reads) +#else +import Text.Read (readMaybe) +#endif + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure, (<$), (<$>), (<*>)) +import Data.Foldable (foldMap) +import Data.Monoid (mempty) +#endif + +import Control.Applicative (many, (<|>)) + +import Codec.Picture (PixelRGBA8 (..)) +import Control.Lens hiding (children, element, + elements, transform) +import Control.Monad.State.Strict (State, gets, modify, runState) +import Data.Attoparsec.Text (Parser, many1, parseOnly, string) +import Data.List (foldl', intercalate) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid (Last (Last), getLast, (<>)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import Graphics.SvgTree.ColorParser +import Graphics.SvgTree.CssParser (complexNumber, dashArray, num, + numberList, ruleSet, styleString) +import Graphics.SvgTree.CssTypes (CssDeclaration (..), + CssElement (..), CssRule, + tserialize) +import Graphics.SvgTree.PathParser +import Graphics.SvgTree.Types +import qualified Text.XML.Light as X +import Text.XML.Light.Proc (elChildren, findAttrBy, + strContent) + +import Text.Printf (printf) + +{-import Debug.Trace-} + +#if !MIN_VERSION_base(4,6,0) +readMaybe :: Read a => String -> Maybe a +readMaybe str = case reads str of + [] -> Nothing + (x, _):_ -> Just x +#endif + +nodeName :: X.Element -> String +nodeName = X.qName . X.elName + +attributeFinder :: String -> X.Element -> Maybe String +attributeFinder str = + findAttrBy (\a -> X.qName a == str) + +-- | Helper class to help simplify parsing code +-- for various attributes. +class ParseableAttribute a where + aparse :: String -> Maybe a + aserialize :: a -> Maybe String + +instance ParseableAttribute v => ParseableAttribute (Maybe v) where + aparse = fmap Just . aparse + aserialize = (>>= aserialize) + +instance ParseableAttribute v => ParseableAttribute (Last v) where + aparse = fmap Last . aparse + aserialize = aserialize . getLast + +instance ParseableAttribute String where + aparse = Just + aserialize = Just + +instance ParseableAttribute Number where + aparse = parseMayStartDot complexNumber + aserialize = Just . serializeNumber + +instance ParseableAttribute [Number] where + aparse = parse dashArray + aserialize = Just . serializeDashArray + +instance ParseableAttribute PixelRGBA8 where + aparse = parse colorParser + aserialize = Just . colorSerializer + +instance ParseableAttribute [PathCommand] where + aparse = parse pathParser + aserialize = Just . serializeCommands + +instance ParseableAttribute GradientPathCommand where + aparse = parse gradientCommand + aserialize = Just . serializeGradientCommand + +instance ParseableAttribute [RPoint] where + aparse = parse pointData + aserialize = Just . serializePoints + +instance ParseableAttribute Double where + aparse = parseMayStartDot num + aserialize v = Just $ printf "%g" v + +instance ParseableAttribute Texture where + aparse = parse textureParser + aserialize = Just . textureSerializer + +instance ParseableAttribute [Transformation] where + aparse = parse $ many transformParser + aserialize = Just . serializeTransformations + +instance ParseableAttribute Alignment where + aparse s = Just $ case s of + "none" -> AlignNone + "xMinYMin" -> AlignxMinYMin + "xMidYMin" -> AlignxMidYMin + "xMaxYMin" -> AlignxMaxYMin + "xMinYMid" -> AlignxMinYMid + "xMidYMid" -> AlignxMidYMid + "xMaxYMid" -> AlignxMaxYMid + "xMinYMax" -> AlignxMinYMax + "xMidYMax" -> AlignxMidYMax + "xMaxYMax" -> AlignxMaxYMax + _ -> _aspectRatioAlign defaultSvg + + aserialize v = Just $ case v of + AlignNone -> "none" + AlignxMinYMin -> "xMinYMin" + AlignxMidYMin -> "xMidYMin" + AlignxMaxYMin -> "xMaxYMin" + AlignxMinYMid -> "xMinYMid" + AlignxMidYMid -> "xMidYMid" + AlignxMaxYMid -> "xMaxYMid" + AlignxMinYMax -> "xMinYMax" + AlignxMidYMax -> "xMidYMax" + AlignxMaxYMax -> "xMaxYMax" + +instance ParseableAttribute MeshGradientType where + aparse s = Just $ case s of + "bilinear" -> GradientBilinear + "bicubic" -> GradientBicubic + _ -> GradientBilinear + + aserialize v = Just $ case v of + GradientBilinear -> "bilinear" + GradientBicubic -> "bicubic" + +instance ParseableAttribute MeetSlice where + aparse s = case s of + "meet" -> Just Meet + "slice" -> Just Slice + _ -> Nothing + + aserialize v = Just $ case v of + Meet -> "meet" + Slice -> "slice" + +instance ParseableAttribute PreserveAspectRatio where + aserialize v = Just $ defer <> align <> meetSlice where + defer = if _aspectRatioDefer v then "defer " else "" + align = fromMaybe "" . aserialize $ _aspectRatioAlign v + meetSlice = fromMaybe "" $ aserialize =<< _aspectRatioMeetSlice v + + aparse s = case words s of + [] -> Nothing + [align] -> Just $ defaultSvg { _aspectRatioAlign = alignOf align } + ["defer", align] -> + Just $ defaultSvg + { _aspectRatioDefer = True + , _aspectRatioAlign = alignOf align + } + [align, meet] -> + Just $ defaultSvg + { _aspectRatioMeetSlice = aparse meet + , _aspectRatioAlign = alignOf align + } + ["defer", align, meet] -> + Just $ PreserveAspectRatio + { _aspectRatioDefer = True + , _aspectRatioAlign = alignOf align + , _aspectRatioMeetSlice = aparse meet + } + _ -> Nothing + where + alignOf = fromMaybe (_aspectRatioAlign defaultSvg) . aparse + +instance ParseableAttribute Cap where + aparse s = case s of + "butt" -> Just CapButt + "round" -> Just CapRound + "square" -> Just CapSquare + _ -> Nothing + + aserialize c = Just $ case c of + CapButt -> "butt" + CapRound -> "round" + CapSquare -> "square" + +instance ParseableAttribute TextAnchor where + aparse s = case s of + "middle" -> Just TextAnchorMiddle + "start" -> Just TextAnchorStart + "end" -> Just TextAnchorEnd + _ -> Nothing + + aserialize t = Just $ case t of + TextAnchorMiddle -> "middle" + TextAnchorStart -> "start" + TextAnchorEnd -> "end" + +instance ParseableAttribute ElementRef where + aparse s = case parseOnly pa $ T.pack s of + Left _ -> Nothing + Right v -> Just v + where + pa = (RefNone <$ string "none") + <|> (Ref <$> urlRef) + + aserialize c = Just $ case c of + Ref r -> "url(#" <> r <> ")" + RefNone -> "none" + +instance ParseableAttribute LineJoin where + aparse s = case s of + "miter" -> Just JoinMiter + "round" -> Just JoinRound + "bevel" -> Just JoinBevel + _ -> Nothing + + aserialize j = Just $ case j of + JoinMiter -> "miter" + JoinRound -> "round" + JoinBevel -> "bevel" + +instance ParseableAttribute CoordinateUnits where + aparse s = case s of + "userSpaceOnUse" -> Just CoordUserSpace + "objectBoundingBox" -> Just CoordBoundingBox + _ -> Just CoordBoundingBox + + aserialize uni = Just $ case uni of + CoordUserSpace -> "userSpaceOnUse" + CoordBoundingBox -> "objectBoundingBox" + +instance ParseableAttribute Spread where + aparse s = case s of + "pad" -> Just SpreadPad + "reflect" -> Just SpreadReflect + "repeat" -> Just SpreadRepeat + _ -> Nothing + + aserialize s = Just $ case s of + SpreadPad -> "pad" + SpreadReflect -> "reflect" + SpreadRepeat -> "repeat" + +instance ParseableAttribute FillRule where + aparse s = case s of + "nonzero" -> Just FillNonZero + "evenodd" -> Just FillEvenOdd + _ -> Nothing + + aserialize f = Just $ case f of + FillNonZero -> "nonzero" + FillEvenOdd -> "evenodd" + +instance ParseableAttribute TextAdjust where + aparse s = Just $ case s of + "spacing" -> TextAdjustSpacing + "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs + _ -> TextAdjustSpacing + + aserialize a = Just $ case a of + TextAdjustSpacing -> "spacing" + TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs" + +instance ParseableAttribute MarkerUnit where + aparse s = case s of + "strokeWidth" -> Just MarkerUnitStrokeWidth + "userSpaceOnUse" -> Just MarkerUnitUserSpaceOnUse + _ -> Nothing + + aserialize u = Just $ case u of + MarkerUnitStrokeWidth -> "strokeWidth" + MarkerUnitUserSpaceOnUse -> "userSpaceOnUse" + +instance ParseableAttribute Overflow where + aparse s = case s of + "visible" -> Just OverflowVisible + "hidden" -> Just OverflowHidden + _ -> Nothing + + aserialize u = Just $ case u of + OverflowVisible -> "visible" + OverflowHidden -> "hidden" + +instance ParseableAttribute MarkerOrientation where + aparse s = case (s, readMaybe s) of + ("auto", _) -> Just OrientationAuto + (_, Just f) -> Just $ OrientationAngle f + _ -> Nothing + + aserialize s = Just $ case s of + OrientationAuto -> "auto" + OrientationAngle f -> show f + +instance ParseableAttribute (Double, Double, Double, Double) where + aparse = parse viewBoxParser + aserialize = Just . serializeViewBox + +instance ParseableAttribute TextPathMethod where + aparse s = case s of + "align" -> Just TextPathAlign + "stretch" -> Just TextPathStretch + _ -> Nothing + aserialize m = Just $ case m of + TextPathAlign -> "align" + TextPathStretch -> "stretch" + +instance ParseableAttribute TextPathSpacing where + aparse s = case s of + "auto" -> Just TextPathSpacingAuto + "exact" -> Just TextPathSpacingExact + _ -> Nothing + + aserialize s = Just $ case s of + TextPathSpacingAuto -> "auto" + TextPathSpacingExact -> "exact" + +parse :: Parser a -> String -> Maybe a +parse p str = case parseOnly p (T.pack str) of + Left _ -> Nothing + Right r -> Just r + +parseMayStartDot :: Parser a -> String -> Maybe a +parseMayStartDot p l@('.':_) = parse p ('0':l) +parseMayStartDot p l = parse p l + +xmlUpdate :: (XMLUpdatable a) => a -> X.Element -> a +xmlUpdate initial el = foldl' grab initial attributes + where + grab value updater = + case attributeFinder (_attributeName updater) el of + Nothing -> value + Just v -> _attributeUpdater updater value v + +xmlUnparse :: (XMLUpdatable a) => X.Element -> a +xmlUnparse = xmlUpdate defaultSvg + +xmlUnparseWithDrawAttr + :: (XMLUpdatable a, WithDrawAttributes a) + => X.Element -> a +xmlUnparseWithDrawAttr e = + xmlUnparse e & drawAttr .~ xmlUnparse e + +data SvgAttributeLens t = SvgAttributeLens + { _attributeName :: String + , _attributeUpdater :: t -> String -> t + , _attributeSerializer :: t -> Maybe String + } + +class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where + xmlTagName :: treeNode -> String + attributes :: [SvgAttributeLens treeNode] + + serializeTreeNode :: treeNode -> Maybe X.Element + +setChildren :: X.Element -> [X.Content] -> X.Element +setChildren xNode children = xNode { X.elContent = children } + +updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> Maybe X.Element -> Maybe X.Element +updateWithAccessor _ _ Nothing = Nothing +updateWithAccessor accessor node (Just xNode) = + Just . setChildren xNode . fmap X.Elem . catMaybes $ serializeTreeNode <$> accessor node + +genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> Maybe X.Element +genericSerializeNode node = + Just . X.unode (xmlTagName node) $ concatMap generateAttribute attributes + where + generateAttribute attr = case _attributeSerializer attr node of + Nothing -> [] + Just str -> return X.Attr + { X.attrKey = xName $ _attributeName attr + , X.attrVal = str + } + where + xName "href" = + X.QName { X.qName = "href" + , X.qURI = Nothing + , X.qPrefix = Just "xlink" } + xName h = X.unqual h + + +mergeAttributes :: X.Element -> X.Element -> X.Element +mergeAttributes thisXml otherXml = + thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml } + +genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode) + => treeNode -> Maybe X.Element +genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where + thisXml = genericSerializeNode node + drawAttrNode = genericSerializeNode $ node ^. drawAttr + +type CssUpdater a = + a -> [[CssElement]] -> a + +opacitySetter :: String -> Lens' a (Maybe Float) -> SvgAttributeLens a +opacitySetter attribute elLens = + SvgAttributeLens attribute updater serializer + where + serializer a = printf "%g" <$> a ^. elLens + updater el str = case parseMayStartDot num str of + Nothing -> el + Just v -> el & elLens .~ Just (realToFrac v) + +type Serializer e = e -> Maybe String + +parserSetter :: String -> Lens' a e -> (String -> Maybe e) -> Serializer e + -> SvgAttributeLens a +parserSetter attribute elLens parser serialize = + SvgAttributeLens attribute updater serializer + where + updater el str = case parser str of + Nothing -> el + Just v -> el & elLens .~ v + + serializer a = serialize $ a ^. elLens + +parseIn :: (Eq a, WithDefaultSvg s, ParseableAttribute a) + => String -> Lens' s a -> SvgAttributeLens s +parseIn attribute elLens = + SvgAttributeLens attribute updater serializer + where + updater el str = case aparse str of + Nothing -> el + Just v -> el & elLens .~ v + + serializer a + | v /= defaultVal = aserialize v + | otherwise = Nothing + where + v = a ^. elLens + defaultVal = defaultSvg ^. elLens + +parserLastSetter :: String -> Lens' a (Last e) -> (String -> Maybe e) -> Serializer e + -> SvgAttributeLens a +parserLastSetter attribute elLens parser serialize = + SvgAttributeLens attribute updater serializer + where + updater el str = case parser str of + Nothing -> el + Just v -> el & elLens .~ Last (Just v) + + serializer a = getLast (a ^. elLens) >>= serialize + +classSetter :: SvgAttributeLens DrawAttributes +classSetter = SvgAttributeLens "class" updater serializer + where + updater el str = + el & attrClass .~ (T.split (== ' ') $ T.pack str) + + serializer a = case a ^. attrClass of + [] -> Nothing + lst -> Just . T.unpack $ T.intercalate " " lst + +cssUniqueNumber :: ASetter el el + a (Last Number) + -> CssUpdater el +cssUniqueNumber setter attr ((CssNumber n:_):_) = + attr & setter .~ Last (Just n) +cssUniqueNumber _ attr _ = attr + +cssUniqueFloat :: (Fractional n) + => ASetter el el a (Maybe n) + -> CssUpdater el +cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = + attr & setter .~ Just (realToFrac n) +cssUniqueFloat _ attr _ = attr + +cssUniqueMayFloat :: ASetter el el a (Last Double) + -> CssUpdater el +cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) = + attr & setter .~ Last (Just n) +cssUniqueMayFloat _ attr _ = attr + +cssIdentAttr :: ParseableAttribute a => Lens' el a -> CssUpdater el +cssIdentAttr setter attr ((CssIdent i:_):_) = case aparse $ T.unpack i of + Nothing -> attr + Just v -> attr & setter .~ v +cssIdentAttr _ attr _ = attr + +fontFamilyParser :: CssUpdater DrawAttributes +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 el el + a (Last Texture) + -> CssUpdater el +cssUniqueTexture setter attr css = case css of + ((CssIdent "none":_):_) -> attr & setter .~ Last (Just FillNone) + ((CssColor c:_):_) -> attr & setter .~ Last (Just $ ColorRef c) + ((CssFunction "url" [CssReference c]:_):_) -> + attr & setter .~ Last (Just . TextureRef $ T.unpack c) + _ -> attr + +cssUniqueColor :: ASetter el el a PixelRGBA8 -> CssUpdater el +cssUniqueColor setter attr css = case css of + ((CssColor c:_):_) -> attr & setter .~ c + _ -> attr + +cssElementRefSetter :: Lens' el (Last ElementRef) -> CssUpdater el +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 el el a (Maybe String) -> CssUpdater el +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 a +cssNullSetter attr _ = attr + +cssDashArray :: ASetter el el a (Last [Number]) -> CssUpdater el +cssDashArray setter attr (lst:_) = + case [n | CssNumber n <- lst ] of + [] -> attr + v -> attr & setter .~ Last (Just v) +cssDashArray _ attr _ = attr + + +drawAttributesList :: [(SvgAttributeLens DrawAttributes, CssUpdater DrawAttributes)] +drawAttributesList = + [("stroke-width" `parseIn` strokeWidth, cssUniqueNumber strokeWidth) + ,("stroke" `parseIn` strokeColor, cssUniqueTexture strokeColor) + ,("fill" `parseIn` fillColor, cssUniqueTexture fillColor) + ,("stroke-linecap" `parseIn` strokeLineCap, cssIdentAttr strokeLineCap) + ,("stroke-linejoin" `parseIn` strokeLineJoin, cssIdentAttr strokeLineJoin) + ,("stroke-miterlimit" `parseIn` strokeMiterLimit, + cssUniqueMayFloat strokeMiterLimit) + + ,("transform" `parseIn` transform, const) + ,(opacitySetter "opacity" groupOpacity, cssUniqueFloat groupOpacity) + ,(opacitySetter "fill-opacity" fillOpacity, cssUniqueFloat fillOpacity) + ,(opacitySetter "stroke-opacity" strokeOpacity, cssUniqueFloat strokeOpacity) + ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize) + ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate) + (Just . intercalate ", "), fontFamilyParser) + + ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule) + ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule) + ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef) + ,(classSetter, cssNullSetter) -- can't set class in CSS + ,("id" `parseIn` attrId, cssMayStringSetter attrId) + ,("stroke-dashoffset" `parseIn` strokeOffset, + cssUniqueNumber strokeOffset) + ,("stroke-dasharray" `parseIn` strokeDashArray, cssDashArray strokeDashArray) + ,("text-anchor" `parseIn` textAnchor, cssIdentAttr textAnchor) + ,("clip-path" `parseIn` clipPathRef, cssElementRefSetter clipPathRef) + ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd) + ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart) + ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid) + ] + where + commaSeparate = + fmap (T.unpack . T.strip) . T.split (',' ==) . T.pack + +serializeDashArray :: [Number] -> String +serializeDashArray = + intercalate ", " . fmap serializeNumber + +instance XMLUpdatable DrawAttributes where + xmlTagName _ = "DRAWATTRIBUTES" + attributes = + styleAttribute drawAttributesList : fmap fst drawAttributesList + serializeTreeNode = genericSerializeNode + +styleAttribute :: [(SvgAttributeLens a, CssUpdater a)] -> SvgAttributeLens a +styleAttribute styleAttrs = 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) <- styleAttrs] + applyer value (CssDeclaration txt elems) = + case lookup txt cssUpdaters of + Nothing -> value + Just f -> f value elems + +instance XMLUpdatable Rectangle where + xmlTagName _ = "rect" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["width" `parseIn` rectWidth + ,"height" `parseIn` rectHeight + ,"x" `parseIn` (rectUpperLeftCorner._1) + ,"y" `parseIn` (rectUpperLeftCorner._2) + ,"rx" `parseIn` (rectCornerRadius._1) + ,"ry" `parseIn` (rectCornerRadius._2) + ] + +instance XMLUpdatable Image where + xmlTagName _ = "image" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["width" `parseIn` imageWidth + ,"height" `parseIn` imageHeight + ,"x" `parseIn` (imageCornerUpperLeft._1) + ,"y" `parseIn` (imageCornerUpperLeft._2) + ,parserSetter "href" imageHref (Just . dropSharp) Just + ,"preserveAspectRatio" `parseIn` imageAspectRatio + ] + +instance XMLUpdatable Line where + xmlTagName _ = "line" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["x1" `parseIn` (linePoint1._1) + ,"y1" `parseIn` (linePoint1._2) + ,"x2" `parseIn` (linePoint2._1) + ,"y2" `parseIn` (linePoint2._2) + ] + +instance XMLUpdatable Ellipse where + xmlTagName _ = "ellipse" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["cx" `parseIn` (ellipseCenter._1) + ,"cy" `parseIn` (ellipseCenter._2) + ,"rx" `parseIn` ellipseXRadius + ,"ry" `parseIn` ellipseYRadius + ] + +instance XMLUpdatable Circle where + xmlTagName _ = "circle" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["cx" `parseIn` (circleCenter._1) + ,"cy" `parseIn` (circleCenter._2) + ,"r" `parseIn` circleRadius + ] + +instance XMLUpdatable Mask where + xmlTagName _ = "mask" + serializeTreeNode node = + updateWithAccessor _maskContent node $ + genericSerializeWithDrawAttr node + + attributes = + ["x" `parseIn` (maskPosition._1) + ,"y" `parseIn` (maskPosition._2) + ,"width" `parseIn` maskWidth + ,"height" `parseIn` maskHeight + ,"maskContentUnits" `parseIn` maskContentUnits + ,"maskUnits" `parseIn` maskUnits + ] + +instance XMLUpdatable ClipPath where + xmlTagName _ = "clipPath" + serializeTreeNode node = + updateWithAccessor _clipPathContent node $ + genericSerializeWithDrawAttr node + attributes = + ["clipPathUnits" `parseIn` clipPathUnits] + +instance XMLUpdatable Polygon where + xmlTagName _ = "polygon" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["points" `parseIn` polygonPoints] + +instance XMLUpdatable PolyLine where + xmlTagName _ = "polyline" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["points" `parseIn` polyLinePoints] + +instance XMLUpdatable Path where + xmlTagName _ = "path" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = ["d" `parseIn` pathDefinition] + +instance XMLUpdatable MeshGradientPatch where + xmlTagName _ = "meshpatch" + attributes = [] + serializeTreeNode node = + updateWithAccessor _meshGradientPatchStops node $ genericSerializeNode node + +instance XMLUpdatable MeshGradientRow where + xmlTagName _ = "meshrow" + serializeTreeNode node = + updateWithAccessor _meshGradientRowPatches node $ genericSerializeNode node + attributes = [] + +instance XMLUpdatable MeshGradient where + xmlTagName _ = "meshgradient" + serializeTreeNode node = + updateWithAccessor _meshGradientRows node $ genericSerializeWithDrawAttr node + attributes = + ["x" `parseIn` meshGradientX + ,"y" `parseIn` meshGradientY + ,"type" `parseIn` meshGradientType + ,"gradientUnits" `parseIn` meshGradientUnits + ,"gradientTransform" `parseIn` meshGradientTransform + ] + + +instance XMLUpdatable LinearGradient where + xmlTagName _ = "linearGradient" + serializeTreeNode node = + updateWithAccessor _linearGradientStops node $ genericSerializeNode node + + attributes = + ["gradientTransform" `parseIn` linearGradientTransform + ,"gradientUnits" `parseIn` linearGradientUnits + ,"spreadMethod" `parseIn` linearGradientSpread + ,"x1" `parseIn` (linearGradientStart._1) + ,"y1" `parseIn` (linearGradientStart._2) + ,"x2" `parseIn` (linearGradientStop._1) + ,"y2" `parseIn` (linearGradientStop._2) + ] + +instance XMLUpdatable Tree where + xmlTagName _ = "TREE" + attributes = [] + serializeTreeNode e = case e of + None -> Nothing + UseTree u _ -> serializeTreeNode u + GroupTree g -> serializeTreeNode g + SymbolTree s -> serializeTreeNode s + DefinitionTree d -> serializeTreeNode d + 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 + LinearGradientTree l -> serializeTreeNode l + RadialGradientTree r -> serializeTreeNode r + MeshGradientTree m -> serializeTreeNode m + PatternTree p -> serializeTreeNode p + MarkerTree m -> serializeTreeNode m + MaskTree m -> serializeTreeNode m + ClipPathTree c -> serializeTreeNode c + TextTree (Just p) t -> do + textNode <- serializeTreeNode t + pathNode <- serializeTreeNode p + let sub = [X.Elem . setChildren pathNode $ X.elContent textNode] + return $ setChildren textNode sub + + +isNotNone :: Tree -> Bool +isNotNone None = False +isNotNone _ = True + +instance XMLUpdatable (Group Tree) where + xmlTagName _ = "g" + serializeTreeNode node = + updateWithAccessor (filter isNotNone . _groupChildren) node $ + genericSerializeWithDrawAttr node + attributes = [] + +instance XMLUpdatable (Symbol Tree) where + xmlTagName _ = "symbol" + serializeTreeNode node = + updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $ + genericSerializeWithDrawAttr node + attributes = + ["viewBox" `parseIn` (groupOfSymbol . groupViewBox) + ,"preserveAspectRatio" `parseIn` (groupOfSymbol . groupAspectRatio) + ] + +instance XMLUpdatable (Definitions Tree) where + xmlTagName _ = "defs" + serializeTreeNode node = + updateWithAccessor (filter isNotNone . _groupChildren . _groupOfDefinitions) node $ + genericSerializeWithDrawAttr node + attributes = + ["viewBox" `parseIn` (groupOfDefinitions . groupViewBox) + ,"preserveAspectRatio" `parseIn` (groupOfDefinitions . groupAspectRatio) + ] + + +instance XMLUpdatable RadialGradient where + xmlTagName _ = "radialGradient" + serializeTreeNode node = + updateWithAccessor _radialGradientStops node $ genericSerializeNode node + attributes = + ["gradientTransform" `parseIn` radialGradientTransform + ,"gradientUnits" `parseIn` radialGradientUnits + ,"spreadMethod" `parseIn` radialGradientSpread + ,"cx" `parseIn` (radialGradientCenter._1) + ,"cy" `parseIn` (radialGradientCenter._2) + ,"r" `parseIn` radialGradientRadius + ,"fx" `parseIn` radialGradientFocusX + ,"fy" `parseIn` radialGradientFocusY + ] + +instance XMLUpdatable Use where + xmlTagName _ = "use" + serializeTreeNode = genericSerializeWithDrawAttr + attributes = + ["x" `parseIn` (useBase._1) + ,"y" `parseIn` (useBase._2) + ,"width" `parseIn` useWidth + ,"height" `parseIn` useHeight + ,parserSetter "href" useName (Just . dropSharp) (Just . ('#':)) + ] + +dropSharp :: String -> String +dropSharp ('#':rest) = rest +dropSharp a = a + +instance XMLUpdatable TextInfo where + xmlTagName _ = "tspan" + serializeTreeNode = genericSerializeNode + attributes = + [parserSetter "x" textInfoX (parse dashArray) dashNotEmpty + ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty + ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty + ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty + ,parserSetter "rotate" textInfoRotate + (parse numberList) + rotateNotEmpty + ,"textLength" `parseIn` textInfoLength + ] + where + dashNotEmpty [] = Nothing + dashNotEmpty lst = Just $ serializeDashArray lst + + rotateNotEmpty [] = Nothing + rotateNotEmpty lst = + Just . unwords $ printf "%g" <$> lst + + +instance XMLUpdatable TextPath where + xmlTagName _ = "textPath" + serializeTreeNode = genericSerializeNode + attributes = + ["startOffset" `parseIn` textPathStartOffset + ,"method" `parseIn` textPathMethod + ,"spacing" `parseIn` textPathSpacing + ,parserSetter "href" textPathName (Just . dropSharp) (Just . ('#':)) + ] + +instance XMLUpdatable Text where + xmlTagName _ = "text" + serializeTreeNode = serializeText + attributes = ["lengthAdjust" `parseIn` textAdjust] + + +instance XMLUpdatable Pattern where + xmlTagName _ = "pattern" + serializeTreeNode node = + updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node + attributes = + ["viewBox" `parseIn` patternViewBox + ,"patternUnits" `parseIn` patternUnit + ,"width" `parseIn` patternWidth + ,"height" `parseIn` patternHeight + ,"x" `parseIn` (patternPos._1) + ,"y" `parseIn` (patternPos._2) + ,"preserveAspectRatio" `parseIn` patternAspectRatio + ,parserSetter "href" patternHref (Just . dropSharp) (Just . ('#':)) + ,"patternTransform" `parseIn` patternTransform + ] + +instance XMLUpdatable Marker where + xmlTagName _ = "marker" + serializeTreeNode node = + updateWithAccessor _markerElements node $ genericSerializeWithDrawAttr node + attributes = + ["refX" `parseIn` (markerRefPoint._1) + ,"refY" `parseIn` (markerRefPoint._2) + ,"markerWidth" `parseIn` markerWidth + ,"markerHeight" `parseIn` markerHeight + ,"patternUnits" `parseIn` markerUnits + ,"orient" `parseIn` markerOrient + ,"viewBox" `parseIn` markerViewBox + ,"overflow" `parseIn` markerOverflow + ,"preserveAspectRatio" `parseIn` markerAspectRatio + ] + +serializeText :: Text -> Maybe X.Element +serializeText topText = namedNode where + namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode + topNode = serializeSpan $ _textRoot topText + + serializeSpan tspan = case (info, drawInfo) of + (Nothing, Nothing) -> Nothing + (Just a, Nothing) -> Just $ setChildren a subContent + (Nothing, Just b) -> Just $ setChildren b subContent + (Just a, Just b) -> + Just $ setChildren (mergeAttributes a b) subContent + where + info = genericSerializeNode $ _spanInfo tspan + drawInfo = genericSerializeNode $ _spanDrawAttributes tspan + subContent = catMaybes $ serializeContent <$> _spanContent tspan + + serializeContent (SpanText t) = Just . X.Text $ X.blank_cdata { X.cdData = T.unpack t } + serializeContent (SpanTextRef _t) = Just . X.Text $ X.blank_cdata { X.cdData = "" } + serializeContent (SpanSub sub) = X.Elem <$> serializeSpan sub + +unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath) +unparseText = extractResult . go True + where + extractResult (a, b, _) = (a, b) + + go startStrip [] = ([], Nothing, startStrip) + go startStrip (X.CRef _:rest) = go startStrip rest + go startStrip (X.Elem e@(nodeName -> "tspan"):rest) = + (SpanSub spans : trest, mpath, retStrip) + where + (trest, mpath, retStrip) = go restStrip rest + (sub, _, restStrip) = go startStrip $ X.elContent e + spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub + + go startStrip (X.Elem e@(nodeName -> "tref"):rest) = + case attributeFinder "href" e of + Nothing -> go startStrip rest + Just v -> (SpanTextRef v : trest, mpath, stripRet) + where (trest, mpath, stripRet) = go startStrip rest + + go startStrip (X.Elem e@(nodeName -> "textPath"):rest) = + case attributeFinder "href" e of + Nothing -> go startStrip rest + Just v -> (tsub ++ trest, pure p, retStrp) + where + p = (xmlUnparse e) { _textPathName = dropSharp v } + (trest, _, retStrp) = go restStrip rest + (tsub, _, restStrip) = go startStrip $ X.elContent e + + go startStrip (X.Elem _:rest) = go startStrip rest + go startStrip (X.Text t:rest) + | T.length cleanText == 0 = go startStrip rest + | otherwise = + (SpanText cleanText : trest, mpath, stripRet) + where + (trest, mpath, stripRet) = go subShouldStrip rest + + subShouldStrip = T.pack " " `T.isSuffixOf` cleanText + + space = T.singleton ' ' + singulariseSpaces tt + | space `T.isPrefixOf` tt = space + | otherwise = tt + + stripStart | startStrip = T.stripStart + | otherwise = id + + cleanText = stripStart + . T.concat + . fmap singulariseSpaces + . T.groupBy (\a b -> (a /= ' ' && b /= ' ') || a == b) + . T.filter (\c -> c /= '\n' && c /= '\r') + . T.map (\c -> if c == '\t' then ' ' else c) + . T.pack + $ X.cdData t + +gradientOffsetSetter :: SvgAttributeLens GradientStop +gradientOffsetSetter = SvgAttributeLens "offset" setter serialize + where + serialize a = Just $ printf "%d%%" percentage + where percentage = floor . (100 *) $ a ^. gradientOffset :: Int + + setter el str = el & gradientOffset .~ val + where + val = realToFrac $ case parseMayStartDot complexNumber str of + Nothing -> 0 + Just (Num n) -> n + Just (Px n) -> n + Just (Percent n) -> n + Just (Em n) -> n + Just (Pc n) -> n + Just (Mm n) -> n + Just (Cm n) -> n + Just (Point n) -> n + Just (Inches n) -> n + +instance XMLUpdatable GradientStop where + xmlTagName _ = "stop" + serializeTreeNode = genericSerializeNode + attributes = styleAttribute cssAvailable : fmap fst cssAvailable ++ lst where + cssAvailable :: [(SvgAttributeLens GradientStop, CssUpdater GradientStop)] + cssAvailable = + [(opacitySetter "stop-opacity" gradientOpacity, (cssUniqueFloat gradientOpacity)) + ,("stop-color" `parseIn` gradientColor, cssUniqueColor gradientColor) + ] + + lst = + [gradientOffsetSetter + ,"path" `parseIn` gradientPath + ] + + +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 _ = [] + +parseMeshGradientPatches :: X.Element -> [MeshGradientPatch] +parseMeshGradientPatches = foldMap unparsePatch . elChildren where + unparsePatch e@(nodeName -> "meshpatch") = [MeshGradientPatch $ parseGradientStops e] + unparsePatch _ = [] + +parseMeshGradientRows :: X.Element -> [MeshGradientRow] +parseMeshGradientRows = foldMap unRows . elChildren where + unRows e@(nodeName -> "meshrow") = [MeshGradientRow $ parseMeshGradientPatches e] + unRows _ = [] + +unparse :: X.Element -> State Symbols Tree +unparse e@(nodeName -> "pattern") = do + subElements <- mapM unparse $ elChildren e + pure $ PatternTree $ pat { _patternElements = subElements} + where + pat = xmlUnparse e +unparse e@(nodeName -> "marker") = do + subElements <- mapM unparse $ elChildren e + pure $ MarkerTree $ mark {_markerElements = subElements } + where + mark = xmlUnparseWithDrawAttr e +unparse e@(nodeName -> "mask") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + parsedMask = xmlUnparseWithDrawAttr e + pure $ MaskTree $ parsedMask { _maskContent = realChildren } +unparse e@(nodeName -> "clipPath") = do + children <- mapM unparse $ elChildren e + let realChildren = filter isNotNone children + parsedClip = xmlUnparseWithDrawAttr e + pure $ ClipPathTree $ parsedClip { _clipPathContent = realChildren } +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 + defsChildren <- mapM unparse $ elChildren e + let realChildren = filter isNotNone defsChildren + pure . DefinitionTree . Definitions $ groupNode & groupChildren .~ realChildren + where + groupNode :: Group Tree + groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e +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 (ElementMeshGradient _) -> 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 = case nodeName e of + "image" -> pure $ ImageTree parsed + "ellipse" -> pure $ EllipseTree parsed + "rect" -> pure $ RectangleTree parsed + "polyline" -> pure $ PolyLineTree parsed + "polygon" -> pure $ PolygonTree parsed + "circle"-> pure $ CircleTree parsed + "line" -> pure $ LineTree parsed + "path" -> pure $ PathTree parsed + "linearGradient" -> + pure $ LinearGradientTree $ parsed & linearGradientStops .~ parseGradientStops e + "radialGradient" -> + pure $ RadialGradientTree $ parsed & radialGradientStops .~ parseGradientStops e + "meshgradient" -> + pure $ MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e + "use" -> pure $ UseTree parsed Nothing + _ -> pure 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 = defs + , _description = "" + , _styleRules = cssStyle named + , _documentLocation = rootLocation + } + where + (parsedElements, named) = + runState (mapM unparse $ elChildren e) emptyState + defs = foldl' (foldTree worker) M.empty parsedElements + worker m t = + case t ^.drawAttr.attrId of + Nothing -> m + Just tid -> M.insert tid t m + 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 ++ children) + where + attr name = X.Attr (X.unqual name) + children = catMaybes [serializeTreeNode el | el <- _elements doc] + + docViewBox = case _viewBox doc of + Nothing -> [] + Just b -> [attr "viewBox" $ serializeViewBox b] + + descTag = case _description doc of + "" -> [] + txt -> [X.node (X.unqual "desc") txt] + + styleTag = case _styleRules doc of + [] -> [] + rules -> [X.node (X.unqual "style") + ([attr "type" "text/css"], txt)] + where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules + + attrs = + docViewBox ++ + [attr "xmlns" "http://www.w3.org/2000/svg" + ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink" + ,attr "version" "1.1"] ++ + catMaybes [attr "width" . serializeNumber <$> _width doc + ,attr "height" . serializeNumber <$> _height doc + ] diff --git a/test/PathParserSpec.hs b/test/PathParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/PathParserSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module PathParserSpec where + +import Data.Attoparsec.Text +import Graphics.Svg.PathParser +import Graphics.Svg.Types +import Linear +import Test.Hspec + + +spec :: Spec +spec = do + describe "num" $ do + it "support shorthand number" $ do + parseOnly command d `shouldBe` Right p + where + d = "M-.10 .10z" + p = MoveTo OriginAbsolute [V2 (-0.1) 0.10] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}