├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── changelog.md ├── executable └── Main.hs ├── src └── Graphics │ ├── Svg.hs │ └── Svg │ ├── ColorParser.hs │ ├── CssParser.hs │ ├── CssTypes.hs │ ├── NamedColors.hs │ ├── PathParser.hs │ ├── Types.hs │ └── XmlParser.hs ├── svg-tree.cabal └── test ├── PathParserSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | gen_test 5 | *.nix 6 | .stack-work 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Vincent Berthoux 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Vincent Berthoux nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: 3 | cabal build 4 | 5 | lint: 6 | hlint . 7 | 8 | doc: 9 | cabal haddock 10 | 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | svg-tree 2 | ======== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/svg-tree.svg)](http://hackage.haskell.org/package/svg-tree) 5 | 6 | SVG loader/serializer for Haskell with a tree type geared toward SVG 7 | rendering. 8 | 9 | The package is available on [Hackage](http://hackage.haskell.org/package/svg-tree) 10 | 11 | Current capabilities 12 | -------------------- 13 | 14 | Currently loading a mix of SVGTiny and SVG Basic, don't handle the 15 | filters. 16 | 17 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | -*-change-log-*- 2 | 3 | v0.6.2.4 June 2019 4 | 5 | * Hopefully not crashing in the presence of unicode inputs (on windows) 6 | 7 | v0.6.2.3 October 2018 8 | 9 | * GHC 8.6 fixes 10 | 11 | v0.6.2.2 December 2017 12 | 13 | * Adding `Semigroup` instances for defined `Monoid`, for GHC 8.4 14 | 15 | v0.6.2.1 December 2017 16 | * Workaround/Fix: removed reliance on Template Haskell to derive lenses, 17 | by writing them directly in the file, using the ddump-splices. For some 18 | reason Haddock associated with GHC 8.2.2 was entering infinite loop on 19 | the Types file. Ugly workaround, but at least it works. 20 | 21 | v0.6.2 August 2017 22 | * Fix: gather named elements even outside of tags. 23 | * Fix: URL ID now can contain more characters. 24 | 25 | v0.6.1: January 2017 26 | * Fix: some gradient mesh parsing, stop can have style (like with Inkscape 0.92) 27 | * Fix: norm say "" is the global tag 28 | * Fix: Adding `xlink:href` attribute on patterns 29 | * Fix: Adding `patternTransform` attribute on patterns 30 | 31 | v0.6: September 2016 32 | * Add SVG 2.0 gradient mesh 33 | 34 | v0.5.1.2: September 2016 35 | * Fix path parsing with white space prefix 36 | 37 | v0.5.1.1: May 2016 38 | * Fix: GHC 8.0 compatibility 39 | 40 | v0.5.1: March 2016 41 | * Fix: serialization of multi criteria css selector. 42 | 43 | v0.5: March 2016: 44 | * Adding: preserveAspectRatio attribute 45 | * Fix: Application of CSS rules with indirect parent/child relation. 46 | 47 | v0.4.2: March 2016 48 | * Enhancement: avoiding serializatinon of empty class attribute 49 | * Fix: incorrect deserialization of complex CSS 50 | * Fix: Really fixing duplicate ID with serialization 51 | 52 | v0.4.1: February 2016 53 | * Fix: fixing duplicate ID with serialization 54 | 55 | v0.4: February 2016 56 | * Breaking change: viewbox types are no longer Int 57 | but double, sneakingly passed in v0.3.2.2. This 58 | version acknoweledge this change 59 | 60 | V0.3.2.2 February 2016 (Deprecated) 61 | * Fix: Bad serialization of some None constructors. 62 | 63 | v0.3.2.1 October 2015 64 | * Fix: Don't add '#' for serialization 65 | 66 | v0.3.2 August 2015 67 | * Fix: allow compilation with GHC 7.4 68 | 69 | v0.3.1 May 2015 70 | * Fix: Bumping lens dependency and removing upper bound. 71 | 72 | v0.3 April 2015 73 | * Breaking change: Switching all the numeric types associated to geometry 74 | to Double precision (thx to Kasbah) 75 | 76 | v0.2 April 2015 77 | * Fix: Differentiating opacity & fill-opacity, as they are 78 | semantically deferent (BREAKING CHANGE!) 79 | 80 | v0.1.1 April 2015 81 | * Fix: Bumping lens bounds 82 | 83 | v0.1.0.2 March 2015 84 | * Fix: Bumping lens bounds 85 | 86 | v0.1.0.1 87 | * Fix: Lowering some lower bounds 88 | 89 | v0.1 90 | * Initial release 91 | 92 | -------------------------------------------------------------------------------- /executable/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Graphics.Svg( loadSvgFile ) 3 | import System.Environment( getArgs ) 4 | import Text.Show.Pretty( pPrint ) 5 | 6 | main :: IO () 7 | main = do 8 | (f:_) <- getArgs 9 | loadSvgFile f >>= pPrint 10 | 11 | -------------------------------------------------------------------------------- /src/Graphics/Svg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Module providing basic input/output for the SVG document, 3 | -- for document building, please refer to Graphics.Svg.Types. 4 | module Graphics.Svg ( -- * Saving/Loading functions 5 | loadSvgFile 6 | , parseSvgFile 7 | , xmlOfDocument 8 | , saveXmlFile 9 | 10 | -- * Manipulation functions 11 | , cssApply 12 | , cssRulesOfText 13 | , applyCSSRules 14 | , resolveUses 15 | 16 | -- * Type definitions 17 | , module Graphics.Svg.Types 18 | ) where 19 | 20 | #if !MIN_VERSION_base(4,8,0) 21 | import Control.Applicative( (<$>) ) 22 | #endif 23 | 24 | import Data.List( foldl' ) 25 | import qualified Data.ByteString as B 26 | import qualified Data.Map as M 27 | import qualified Data.Text as T 28 | import qualified Data.Text.Encoding as T 29 | import Text.XML.Light.Input( parseXMLDoc ) 30 | import Text.XML.Light.Output( ppcTopElement, prettyConfigPP ) 31 | import Control.Lens 32 | 33 | import Graphics.Svg.Types 34 | import Graphics.Svg.CssTypes 35 | import Graphics.Svg.CssParser( cssRulesOfText ) 36 | import Graphics.Svg.XmlParser 37 | 38 | {-import Graphics.Svg.CssParser-} 39 | 40 | -- | Try to load an svg file on disc and parse it as 41 | -- a SVG Document. 42 | loadSvgFile :: FilePath -> IO (Maybe Document) 43 | loadSvgFile filename = 44 | parseSvgFile filename <$> B.readFile filename 45 | 46 | -- | Parse an in-memory SVG file 47 | parseSvgFile :: FilePath -- ^ Source path/URL of the document, used 48 | -- to resolve relative links. 49 | -> B.ByteString 50 | -> Maybe Document 51 | parseSvgFile filename fileContent = 52 | parseXMLDoc fileContent >>= unparseDocument filename 53 | 54 | -- | Save a svg Document on a file on disk. 55 | saveXmlFile :: FilePath -> Document -> IO () 56 | saveXmlFile filePath = 57 | B.writeFile filePath 58 | . T.encodeUtf8 59 | . T.pack 60 | . ppcTopElement prettyConfigPP 61 | . xmlOfDocument 62 | 63 | cssDeclApplyer :: DrawAttributes -> CssDeclaration 64 | -> DrawAttributes 65 | cssDeclApplyer value (CssDeclaration txt elems) = 66 | case lookup txt cssUpdaters of 67 | Nothing -> value 68 | Just f -> f value elems 69 | where 70 | cssUpdaters = [(T.pack $ _attributeName n, u) | 71 | (n, u) <- drawAttributesList] 72 | 73 | -- | Rewrite a SVG Tree using some CSS rules. 74 | -- 75 | -- This action will propagate the definition of the 76 | -- css directly in each matched element. 77 | cssApply :: [CssRule] -> Tree -> Tree 78 | cssApply rules = zipTree go where 79 | go [] = None 80 | go ([]:_) = None 81 | go context@((t:_):_) = t & drawAttr .~ attr' 82 | where 83 | matchingDeclarations = 84 | findMatchingDeclarations rules context 85 | attr = view drawAttr t 86 | attr' = foldl' cssDeclApplyer attr matchingDeclarations 87 | 88 | -- | For every 'use' tag, try to resolve the geometry associated 89 | -- with it and place it in the scene Tree. It is important to 90 | -- resolve the 'use' tag before applying the CSS rules, as some 91 | -- rules may apply some elements matching the children of "use". 92 | resolveUses :: Document -> Document 93 | resolveUses doc = 94 | doc { _elements = mapTree fetchUses <$> _elements doc } 95 | where 96 | fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo 97 | fetchUses a = a 98 | 99 | search nfo = maybe Nothing geometryExtract found where 100 | found = M.lookup (_useName nfo) $ _definitions doc 101 | 102 | geometryExtract c = case c of 103 | ElementLinearGradient _ -> Nothing 104 | ElementRadialGradient _ -> Nothing 105 | ElementMeshGradient _ -> Nothing 106 | ElementMask _ -> Nothing 107 | ElementClipPath _ -> Nothing 108 | ElementGeometry t -> Just t 109 | ElementPattern _ -> Nothing 110 | ElementMarker _ -> Nothing 111 | 112 | -- | Rewrite the document by applying the CSS rules embedded 113 | -- inside it. 114 | applyCSSRules :: Document -> Document 115 | applyCSSRules doc = doc 116 | { _elements = cssApply (_styleRules doc) <$> _elements doc } 117 | 118 | -------------------------------------------------------------------------------- /src/Graphics/Svg/ColorParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Graphics.Svg.ColorParser( colorParser 4 | , colorSerializer 5 | , textureParser 6 | , textureSerializer 7 | , urlRef 8 | ) where 9 | 10 | #if !MIN_VERSION_base(4,8,0) 11 | import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) ) 12 | #endif 13 | 14 | import Data.Bits( (.|.), unsafeShiftL ) 15 | import Control.Applicative( (<|>) ) 16 | import Data.Attoparsec.Text 17 | ( Parser 18 | , string 19 | , skipSpace 20 | , satisfy 21 | , inClass 22 | , takeWhile1 23 | , option 24 | , char 25 | , digit 26 | , letter 27 | , many1 28 | , scientific 29 | ) 30 | 31 | import Text.Printf( printf ) 32 | import Data.Scientific( toRealFloat ) 33 | import Codec.Picture( PixelRGBA8( .. ) ) 34 | import Data.Word( Word8 ) 35 | import Graphics.Svg.NamedColors 36 | import Graphics.Svg.Types 37 | import qualified Data.Map as M 38 | 39 | commaWsp :: Parser () 40 | commaWsp = skipSpace *> option () (string "," *> return ()) 41 | <* skipSpace 42 | 43 | 44 | num :: Parser Double 45 | num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) 46 | where doubleNumber :: Parser Double 47 | doubleNumber = toRealFloat <$> scientific 48 | 49 | plusMinus = negate <$ string "-" <*> doubleNumber 50 | <|> string "+" *> doubleNumber 51 | <|> doubleNumber 52 | 53 | colorSerializer :: PixelRGBA8 -> String 54 | colorSerializer (PixelRGBA8 r g b _) = printf "#%02X%02X%02X" r g b 55 | 56 | colorParser :: Parser PixelRGBA8 57 | colorParser = rgbColor 58 | <|> (string "#" *> (color <|> colorReduced)) 59 | <|> namedColor 60 | where 61 | charRange c1 c2 = 62 | (\c -> fromIntegral $ fromEnum c - fromEnum c1) <$> satisfy (\v -> c1 <= v && v <= c2) 63 | black = PixelRGBA8 0 0 0 255 64 | 65 | hexChar :: Parser Word8 66 | hexChar = charRange '0' '9' 67 | <|> ((+ 10) <$> charRange 'a' 'f') 68 | <|> ((+ 10) <$> charRange 'A' 'F') 69 | 70 | namedColor = do 71 | str <- takeWhile1 (inClass "a-z") 72 | return $ M.findWithDefault black str svgNamedColors 73 | 74 | percentToWord v = floor $ v * (255 / 100) 75 | 76 | numPercent = ((percentToWord <$> num) <* string "%") 77 | <|> (floor <$> num) 78 | 79 | hexByte = (\h1 h2 -> h1 `unsafeShiftL` 4 .|. h2) 80 | <$> hexChar <*> hexChar 81 | 82 | color = (\r g b -> PixelRGBA8 r g b 255) 83 | <$> hexByte <*> hexByte <*> hexByte 84 | rgbColor = (\r g b -> PixelRGBA8 r g b 255) 85 | <$> (string "rgb(" *> numPercent) 86 | <*> (commaWsp *> numPercent) 87 | <*> (commaWsp *> numPercent <* skipSpace <* string ")") 88 | 89 | colorReduced = 90 | (\r g b -> PixelRGBA8 (r * 17) (g * 17) (b * 17) 255) 91 | <$> hexChar <*> hexChar <*> hexChar 92 | 93 | 94 | textureSerializer :: Texture -> String 95 | textureSerializer (ColorRef px) = colorSerializer px 96 | textureSerializer (TextureRef str) = printf "url(#%s)" str 97 | textureSerializer FillNone = "none" 98 | 99 | urlRef :: Parser String 100 | urlRef = string "url(" *> skipSpace *> 101 | char '#' *> many1 (letter <|> digit <|> char '_' <|> char '.' <|> char '-' <|> char ':') 102 | <* skipSpace <* char ')' <* skipSpace 103 | 104 | 105 | textureParser :: Parser Texture 106 | textureParser = 107 | none <|> (TextureRef <$> urlRef) 108 | <|> (ColorRef <$> colorParser) 109 | where 110 | none = FillNone <$ string "none" 111 | 112 | -------------------------------------------------------------------------------- /src/Graphics/Svg/CssParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | module Graphics.Svg.CssParser 5 | ( CssElement( .. ) 6 | , complexNumber 7 | , declaration 8 | , ruleSet 9 | , styleString 10 | , dashArray 11 | , numberList 12 | , num 13 | , cssRulesOfText 14 | ) 15 | where 16 | 17 | #if !MIN_VERSION_base(4,8,0) 18 | import Control.Applicative( (<*>), (<*), (*>) 19 | , (<$>), (<$) 20 | , pure 21 | ) 22 | #endif 23 | 24 | import Control.Applicative( (<|>) 25 | , many 26 | ) 27 | import Data.Attoparsec.Text 28 | ( Parser 29 | , double 30 | , string 31 | , skipSpace 32 | , letter 33 | , char 34 | , digit 35 | {-, skip-} 36 | , sepBy1 37 | , () 38 | , skipMany 39 | , notChar 40 | , parseOnly 41 | ) 42 | import qualified Data.Attoparsec.Text as AT 43 | 44 | import Data.Attoparsec.Combinator 45 | ( option 46 | , sepBy 47 | {-, sepBy1-} 48 | , many1 49 | ) 50 | 51 | import Codec.Picture( PixelRGBA8( .. ) ) 52 | import Graphics.Svg.Types 53 | import Graphics.Svg.NamedColors( svgNamedColors ) 54 | import Graphics.Svg.ColorParser( colorParser ) 55 | import Graphics.Svg.CssTypes 56 | import qualified Data.Text as T 57 | import qualified Data.Map as M 58 | {-import Graphics.Rasterific.Linear( V2( V2 ) )-} 59 | {-import Graphics.Rasterific.Transformations-} 60 | 61 | num :: Parser Double 62 | num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) 63 | where doubleNumber = char '.' *> (scale <$> double) 64 | <|> double 65 | 66 | scalingCoeff n = 10 ^ digitCount 67 | where digitCount :: Int 68 | digitCount = ceiling . logBase 10 $ abs n 69 | 70 | scale n = n / scalingCoeff n 71 | 72 | plusMinus = negate <$ string "-" <*> doubleNumber 73 | <|> string "+" *> doubleNumber 74 | <|> doubleNumber 75 | 76 | 77 | ident :: Parser T.Text 78 | ident = 79 | (\f c -> f . T.cons c . T.pack) 80 | <$> trailingSub 81 | <*> nmstart <*> nmchar 82 | where 83 | trailingSub = option id $ T.cons '-' <$ char '-' 84 | underscore = char '_' 85 | nmstart = letter <|> underscore 86 | nmchar = many (letter <|> digit <|> underscore <|> char '-') 87 | 88 | str :: Parser T.Text 89 | str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace 90 | "str" 91 | 92 | between :: Char -> Char -> Parser a -> Parser a 93 | between o e p = 94 | (skipSpace *> 95 | char o *> skipSpace *> p 96 | <* skipSpace <* char e <* skipSpace) 97 | ("between " ++ [o, e]) 98 | 99 | bracket :: Parser a -> Parser a 100 | bracket = between '[' ']' 101 | 102 | 103 | comment :: Parser () 104 | comment = string "/*" *> toStar *> skipSpace 105 | where 106 | toStar = skipMany (notChar '*') *> char '*' *> testEnd 107 | testEnd = (() <$ char '/') <|> toStar 108 | 109 | cleanSpace :: Parser () 110 | cleanSpace = skipSpace <* many comment 111 | 112 | -- | combinator: '+' S* | '>' S* 113 | combinator :: Parser CssSelector 114 | combinator = parse <* cleanSpace where 115 | parse = Nearby <$ char '+' 116 | <|> DirectChildren <$ char '>' 117 | "combinator" 118 | 119 | -- unary_operator : '-' | '+' ; 120 | 121 | commaWsp :: Parser Char 122 | commaWsp = skipSpace *> option ',' (char ',') <* skipSpace 123 | 124 | ruleSet :: Parser CssRule 125 | ruleSet = cleanSpace *> rule where 126 | rule = CssRule 127 | <$> selector `sepBy1` commaWsp 128 | <*> (between '{' '}' styleString) 129 | "cssrule" 130 | 131 | styleString :: Parser [CssDeclaration] 132 | styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp 133 | "styleString" 134 | where semiWsp = skipSpace *> char ';' <* skipSpace 135 | mayWsp = option ';' semiWsp 136 | 137 | selector :: Parser [CssSelector] 138 | selector = (:) 139 | <$> (AllOf <$> simpleSelector <* skipSpace "firstpart:(") 140 | <*> ((next <|> return []) "secondpart") 141 | "selector" 142 | where 143 | combOpt :: Parser ([CssSelector] -> [CssSelector]) 144 | 145 | combOpt = cleanSpace *> option id ((:) <$> combinator) 146 | next :: Parser [CssSelector] 147 | next = id <$> combOpt <*> selector 148 | 149 | simpleSelector :: Parser [CssDescriptor] 150 | simpleSelector = (:) <$> elementName <*> many whole 151 | <|> (many1 whole "inmany") 152 | "simple selector" 153 | where 154 | whole = pseudo <|> hash <|> classParser <|> attrib 155 | "whole" 156 | pseudo = char ':' *> (OfPseudoClass <$> ident) 157 | "pseudo" 158 | hash = char '#' *> (OfId <$> ident) 159 | "hash" 160 | classParser = char '.' *> (OfClass <$> ident) 161 | "classParser" 162 | 163 | elementName = el <* skipSpace "elementName" 164 | where el = (OfName <$> ident) 165 | <|> AnyElem <$ char '*' 166 | 167 | attrib = bracket 168 | (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str)) 169 | "attrib") 170 | 171 | declaration :: Parser CssDeclaration 172 | declaration = 173 | CssDeclaration <$> property 174 | <*> (char ':' 175 | *> cleanSpace 176 | *> many1 expr 177 | <* prio 178 | ) 179 | "declaration" 180 | where 181 | property = (ident <* cleanSpace) "property" 182 | prio = option "" $ string "!important" 183 | 184 | operator :: Parser CssElement 185 | operator = skipSpace *> op <* skipSpace 186 | where 187 | op = CssOpSlash <$ char '/' 188 | <|> CssOpComa <$ char ',' 189 | "operator" 190 | 191 | expr :: Parser [CssElement] 192 | expr = ((:) <$> term <*> (concat <$> many termOp)) 193 | "expr" 194 | where 195 | op = option (:[]) $ (\a b -> [a, b]) <$> operator 196 | termOp = ($) <$> op <*> term 197 | 198 | dashArray :: Parser [Number] 199 | dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp) 200 | 201 | numberList :: Parser [Double] 202 | numberList = skipSpace *> (num `sepBy1` commaWsp) 203 | 204 | complexNumber :: Parser Number 205 | complexNumber = do 206 | n <- num 207 | (Percent (n / 100) <$ char '%') 208 | <|> (Em n <$ string "em") 209 | <|> (Mm n <$ string "mm") 210 | <|> (Cm n <$ string "cm") 211 | <|> (Point n <$ string "pt") 212 | <|> (Pc n <$ string "pc") 213 | <|> (Px n <$ string "px") 214 | <|> (Inches n <$ string "in") 215 | <|> pure (Num n) 216 | 217 | term :: Parser CssElement 218 | term = checkRgb <$> function 219 | <|> (CssNumber <$> complexNumber) 220 | <|> (CssString <$> str) 221 | <|> (checkNamedColor <$> ident) 222 | <|> (CssColor <$> colorParser) 223 | where 224 | comma = skipSpace *> char ',' <* skipSpace 225 | checkNamedColor n 226 | | Just c <- M.lookup n svgNamedColors = CssColor c 227 | | otherwise = CssIdent n 228 | 229 | ref = char '#' *> ident 230 | 231 | checkRgb (CssFunction "rgb" 232 | [CssNumber r, CssNumber g, CssNumber b]) = 233 | CssColor $ PixelRGBA8 (to r) (to g) (to b) 255 234 | where clamp = max 0 . min 255 235 | to (Num n) = floor $ clamp n 236 | to (Px n) = floor $ clamp n 237 | to (Percent p) = floor . clamp $ p * 255 238 | to (Em c) = floor $ clamp c 239 | to (Pc n) = floor $ clamp n 240 | to (Mm n) = floor $ clamp n 241 | to (Cm n) = floor $ clamp n 242 | to (Point n) = floor $ clamp n 243 | to (Inches n) = floor $ clamp n 244 | 245 | checkRgb a = a 246 | functionParam = (CssReference <$> ref) <|> term 247 | 248 | function = CssFunction 249 | <$> ident <* char '(' 250 | <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace 251 | 252 | -- | Parse CSS text into rules. 253 | cssRulesOfText :: T.Text -> [CssRule] 254 | cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of 255 | Left _ -> [] 256 | Right rules -> rules 257 | 258 | -------------------------------------------------------------------------------- /src/Graphics/Svg/CssTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | -- | Define the types used to describes CSS elements 4 | module Graphics.Svg.CssTypes 5 | ( CssSelector( .. ) 6 | , CssSelectorRule 7 | , CssRule( .. ) 8 | , CssDescriptor( .. ) 9 | , CssDeclaration( .. ) 10 | , CssElement( .. ) 11 | 12 | , CssMatcheable( .. ) 13 | , CssContext 14 | , Dpi 15 | , Number( .. ) 16 | , serializeNumber 17 | , findMatchingDeclarations 18 | , toUserUnit 19 | , mapNumber 20 | , tserialize 21 | ) where 22 | 23 | #if !MIN_VERSION_base(4,8,0) 24 | import Data.Monoid( mconcat ) 25 | #endif 26 | 27 | import Data.Monoid( (<>) ) 28 | import Data.List( intersperse ) 29 | import qualified Data.Text as T 30 | import qualified Data.Text.Lazy.Builder as TB 31 | import Text.Printf 32 | 33 | import Codec.Picture( PixelRGBA8( .. ) ) 34 | 35 | -- | Alias describing a "dot per inch" information 36 | -- used for size calculation (see toUserUnit). 37 | type Dpi = Int 38 | 39 | -- | Helper typeclass for serialization to Text. 40 | class TextBuildable a where 41 | -- | Serialize an element to a text builder. 42 | tserialize :: a -> TB.Builder 43 | 44 | -- | Describe an element of a CSS selector. Multiple 45 | -- elements can be combined in a CssSelector type. 46 | data CssDescriptor 47 | = OfClass T.Text -- ^ .IDENT 48 | | OfName T.Text -- ^ IDENT 49 | | OfId T.Text -- ^ #IDENT 50 | | OfPseudoClass T.Text -- ^ `:IDENT` (ignore function syntax) 51 | | AnyElem -- ^ '*' 52 | | WithAttrib T.Text T.Text -- ^ `` 53 | deriving (Eq, Show) 54 | 55 | instance TextBuildable CssDescriptor where 56 | tserialize d = case d of 57 | OfClass c -> si '.' <> ft c 58 | OfName n -> ft n 59 | OfId i -> si '#' <> ft i 60 | OfPseudoClass c -> si '#' <> ft c 61 | AnyElem -> si '*' 62 | WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']'] 63 | where 64 | ft = TB.fromText 65 | si = TB.singleton 66 | 67 | -- | Define complex selector. 68 | data CssSelector 69 | = Nearby -- ^ Correspond to the `+` CSS selector. 70 | | DirectChildren -- ^ Correspond to the `>` CSS selectro. 71 | | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements 72 | -- of the list must be matched. 73 | deriving (Eq, Show) 74 | 75 | instance TextBuildable CssSelector where 76 | tserialize s = case s of 77 | Nearby -> si '+' 78 | DirectChildren -> si '>' 79 | AllOf lst -> mconcat $ map tserialize lst 80 | where 81 | si = TB.singleton 82 | 83 | -- | A CssSelectorRule is a list of all the elements 84 | -- that must be meet in a depth first search fashion. 85 | type CssSelectorRule = [CssSelector] 86 | 87 | -- | Represent a CSS selector and the different declarations 88 | -- to apply to the matched elemens. 89 | data CssRule = CssRule 90 | { -- | At the first level represent a list of elements 91 | -- to be matched. If any match is made, you can apply 92 | -- the declarations. At the second level 93 | cssRuleSelector :: ![CssSelectorRule] 94 | -- | Declarations to apply to the matched element. 95 | , cssDeclarations :: ![CssDeclaration] 96 | } 97 | deriving (Eq, Show) 98 | 99 | instance TextBuildable CssRule where 100 | tserialize (CssRule selectors decl) = 101 | mconcat tselectors 102 | <> ft " {\n" 103 | <> mconcat (fmap tserializeDecl decl) 104 | <> ft "}\n" 105 | where 106 | ft = TB.fromText 107 | tserializeDecl d = ft " " <> tserialize d <> ft ";\n" 108 | tselector = 109 | mconcat . intersperse (ft " ") . fmap tserialize 110 | tselectors = 111 | intersperse (ft ",\n") $ fmap tselector selectors 112 | 113 | -- | Interface for elements to be matched against 114 | -- some CssRule. 115 | class CssMatcheable a where 116 | -- | For an element, tell its optional ID attribute. 117 | cssIdOf :: a -> Maybe T.Text 118 | -- | For an element, return all of it's class attributes. 119 | cssClassOf :: a -> [T.Text] 120 | -- | Return the name of the tagname of the element 121 | cssNameOf :: a -> T.Text 122 | -- | Return a value of a given attribute if present 123 | cssAttribOf :: a -> T.Text -> Maybe T.Text 124 | 125 | -- | Represent a zipper in depth at the first list 126 | -- level, and the previous nodes at in the second 127 | -- list level. 128 | type CssContext a = [[a]] 129 | 130 | isDescribedBy :: CssMatcheable a 131 | => a -> [CssDescriptor] -> Bool 132 | isDescribedBy e = all tryMatch 133 | where 134 | tryMatch (OfClass t) = t `elem` cssClassOf e 135 | tryMatch (OfId i) = cssIdOf e == Just i 136 | tryMatch (OfName n) = cssNameOf e == n 137 | tryMatch (OfPseudoClass _) = False 138 | tryMatch (WithAttrib a v) = cssAttribOf e a == Just v 139 | tryMatch AnyElem = True 140 | 141 | isMatching :: CssMatcheable a 142 | => CssContext a -> [CssSelector] -> Bool 143 | isMatching = go where 144 | go _ [] = True 145 | go [] _ = False 146 | go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest 147 | go ((e:_):upper) (DirectChildren:AllOf descr:rest) 148 | | isDescribedBy e descr = go upper rest 149 | go _ (DirectChildren:_) = False 150 | go ((e:_):upper) selectors@(AllOf descr : rest) 151 | | isDescribedBy e descr = go upper rest 152 | | otherwise = go upper selectors 153 | go (_:upper) selector = go upper selector 154 | 155 | -- | Given CSS rules, find all the declaration to apply to the 156 | -- element in a given context. 157 | findMatchingDeclarations :: CssMatcheable a 158 | => [CssRule] -> CssContext a -> [CssDeclaration] 159 | findMatchingDeclarations rules context = 160 | concat [cssDeclarations rule 161 | | rule <- rules 162 | , selector <- cssRuleSelector rule 163 | , isMatching context $ reverse selector ] 164 | 165 | -- | Represent the content to apply to some 166 | -- CSS matched rules. 167 | data CssDeclaration = CssDeclaration 168 | { -- | Property name to change (like font-family or color). 169 | _cssDeclarationProperty :: T.Text 170 | -- | List of values 171 | , _cssDecarationlValues :: [[CssElement]] 172 | } 173 | deriving (Eq, Show) 174 | 175 | instance TextBuildable CssDeclaration where 176 | tserialize (CssDeclaration n elems) = 177 | mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems 178 | where 179 | finalElems = map tserialize (concat elems) 180 | ft = TB.fromText 181 | si = TB.singleton 182 | 183 | 184 | -- | Encode complex number possibly dependant to the current 185 | -- render size. 186 | data Number 187 | = Num Double -- ^ Simple coordinate in current user coordinate. 188 | | Px Double -- ^ With suffix "px" 189 | | Em Double -- ^ Number relative to the current font size. 190 | | Percent Double -- ^ Number relative to the current viewport size. 191 | | Pc Double 192 | | Mm Double -- ^ Number in millimeters, relative to DPI. 193 | | Cm Double -- ^ Number in centimeters, relative to DPI. 194 | | Point Double -- ^ Number in points, relative to DPI. 195 | | Inches Double -- ^ Number in inches, relative to DPI. 196 | deriving (Eq, Show) 197 | 198 | -- | Helper function to modify inner value of a number 199 | mapNumber :: (Double -> Double) -> Number -> Number 200 | mapNumber f nu = case nu of 201 | Num n -> Num $ f n 202 | Px n -> Px $ f n 203 | Em n -> Em $ f n 204 | Percent n -> Percent $ f n 205 | Pc n -> Pc $ f n 206 | Mm n -> Mm $ f n 207 | Cm n -> Cm $ f n 208 | Point n -> Point $ f n 209 | Inches n -> Inches $ f n 210 | 211 | -- | Encode the number to string which can be used in a 212 | -- CSS or a svg attributes. 213 | serializeNumber :: Number -> String 214 | serializeNumber n = case n of 215 | Num c -> printf "%g" c 216 | Px c -> printf "%gpx" c 217 | Em cc -> printf "%gem" cc 218 | Percent p -> printf "%d%%" (floor $ 100 * p :: Int) 219 | Pc p -> printf "%gpc" p 220 | Mm m -> printf "%gmm" m 221 | Cm c -> printf "%gcm" c 222 | Point p -> printf "%gpt" p 223 | Inches i -> printf "%gin" i 224 | 225 | instance TextBuildable Number where 226 | tserialize = TB.fromText . T.pack . serializeNumber 227 | 228 | -- | Value of a CSS property. 229 | data CssElement 230 | = CssIdent !T.Text 231 | | CssString !T.Text 232 | | CssReference !T.Text 233 | | CssNumber !Number 234 | | CssColor !PixelRGBA8 235 | | CssFunction !T.Text ![CssElement] 236 | | CssOpComa 237 | | CssOpSlash 238 | deriving (Eq, Show) 239 | 240 | instance TextBuildable CssElement where 241 | tserialize e = case e of 242 | CssIdent n -> ft n 243 | CssString s -> si '"' <> ft s <> si '"' 244 | CssReference r -> si '#' <> ft r 245 | CssNumber n -> tserialize n 246 | CssColor (PixelRGBA8 r g b _) -> 247 | ft . T.pack $ printf "#%02X%02X%02X" r g b 248 | CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')'] 249 | where args = intersperse (ft ", ") (map tserialize els) 250 | CssOpComa -> si ',' 251 | CssOpSlash -> si '/' 252 | where 253 | ft = TB.fromText 254 | si = TB.singleton 255 | 256 | -- | This function replace all device dependant units to user 257 | -- units given it's DPI configuration. 258 | -- Preserve percentage and "em" notation. 259 | toUserUnit :: Dpi -> Number -> Number 260 | toUserUnit dpi = go where 261 | go nu = case nu of 262 | Num _ -> nu 263 | Px p -> go $ Num p 264 | Em _ -> nu 265 | Percent _ -> nu 266 | Pc n -> go . Inches $ (12 * n) / 72 267 | Inches n -> Num $ n * fromIntegral dpi 268 | Mm n -> go . Inches $ n / 25.4 269 | Cm n -> go . Inches $ n / 2.54 270 | Point n -> go . Inches $ n / 72 271 | 272 | -------------------------------------------------------------------------------- /src/Graphics/Svg/NamedColors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Graphics.Svg.NamedColors( svgNamedColors ) where 3 | 4 | import qualified Data.Map as M 5 | import Codec.Picture( PixelRGBA8( .. ) ) 6 | import Data.Text( Text ) 7 | 8 | svgNamedColors :: M.Map Text PixelRGBA8 9 | svgNamedColors = M.fromList 10 | [ ("aliceblue" , PixelRGBA8 240 248 255 255) 11 | , ("antiquewhite" , PixelRGBA8 250 235 215 255) 12 | , ("aqua" , PixelRGBA8 0 255 255 255) 13 | , ("aquamarine" , PixelRGBA8 127 255 212 255) 14 | , ("azure" , PixelRGBA8 240 255 255 255) 15 | , ("beige" , PixelRGBA8 245 245 220 255) 16 | , ("bisque" , PixelRGBA8 255 228 196 255) 17 | , ("black" , PixelRGBA8 0 0 0 255) 18 | , ("blanchedalmond" , PixelRGBA8 255 235 205 255) 19 | , ("blue" , PixelRGBA8 0 0 255 255) 20 | , ("blueviolet" , PixelRGBA8 138 43 226 255) 21 | , ("brown" , PixelRGBA8 165 42 42 255) 22 | , ("burlywood" , PixelRGBA8 222 184 135 255) 23 | , ("cadetblue" , PixelRGBA8 95 158 160 255) 24 | , ("chartreuse" , PixelRGBA8 127 255 0 255) 25 | , ("chocolate" , PixelRGBA8 210 105 30 255) 26 | , ("coral" , PixelRGBA8 255 127 80 255) 27 | , ("cornflowerblue" , PixelRGBA8 100 149 237 255) 28 | , ("cornsilk" , PixelRGBA8 255 248 220 255) 29 | , ("crimson" , PixelRGBA8 220 20 60 255) 30 | , ("cyan" , PixelRGBA8 0 255 255 255) 31 | , ("darkblue" , PixelRGBA8 0 0 139 255) 32 | , ("darkcyan" , PixelRGBA8 0 139 139 255) 33 | , ("darkgoldenrod" , PixelRGBA8 184 134 11 255) 34 | , ("darkgray" , PixelRGBA8 169 169 169 255) 35 | , ("darkgreen" , PixelRGBA8 0 100 0 255) 36 | , ("darkgrey" , PixelRGBA8 169 169 169 255) 37 | , ("darkkhaki" , PixelRGBA8 189 183 107 255) 38 | , ("darkmagenta" , PixelRGBA8 139 0 139 255) 39 | , ("darkolivegreen" , PixelRGBA8 85 107 47 255) 40 | , ("darkorange" , PixelRGBA8 255 140 0 255) 41 | , ("darkorchid" , PixelRGBA8 153 50 204 255) 42 | , ("darkred" , PixelRGBA8 139 0 0 255) 43 | , ("darksalmon" , PixelRGBA8 233 150 122 255) 44 | , ("darkseagreen" , PixelRGBA8 143 188 143 255) 45 | , ("darkslateblue" , PixelRGBA8 72 61 139 255) 46 | , ("darkslategray" , PixelRGBA8 47 79 79 255) 47 | , ("darkslategrey" , PixelRGBA8 47 79 79 255) 48 | , ("darkturquoise" , PixelRGBA8 0 206 209 255) 49 | , ("darkviolet" , PixelRGBA8 148 0 211 255) 50 | , ("deeppink" , PixelRGBA8 255 20 147 255) 51 | , ("deepskyblue" , PixelRGBA8 0 191 255 255) 52 | , ("dimgray" , PixelRGBA8 105 105 105 255) 53 | , ("dimgrey" , PixelRGBA8 105 105 105 255) 54 | , ("dodgerblue" , PixelRGBA8 30 144 255 255) 55 | , ("firebrick" , PixelRGBA8 178 34 34 255) 56 | , ("floralwhite" , PixelRGBA8 255 250 240 255) 57 | , ("forestgreen" , PixelRGBA8 34 139 34 255) 58 | , ("fuchsia" , PixelRGBA8 255 0 255 255) 59 | , ("gainsboro" , PixelRGBA8 220 220 220 255) 60 | , ("ghostwhite" , PixelRGBA8 248 248 255 255) 61 | , ("gold" , PixelRGBA8 255 215 0 255) 62 | , ("goldenrod" , PixelRGBA8 218 165 32 255) 63 | , ("gray" , PixelRGBA8 128 128 128 255) 64 | , ("grey" , PixelRGBA8 128 128 128 255) 65 | , ("green" , PixelRGBA8 0 128 0 255) 66 | , ("greenyellow" , PixelRGBA8 173 255 47 255) 67 | , ("honeydew" , PixelRGBA8 240 255 240 255) 68 | , ("hotpink" , PixelRGBA8 255 105 180 255) 69 | , ("indianred" , PixelRGBA8 205 92 92 255) 70 | , ("indigo" , PixelRGBA8 75 0 130 255) 71 | , ("ivory" , PixelRGBA8 255 255 240 255) 72 | , ("khaki" , PixelRGBA8 240 230 140 255) 73 | , ("lavender" , PixelRGBA8 230 230 250 255) 74 | , ("lavenderblush" , PixelRGBA8 255 240 245 255) 75 | , ("lawngreen" , PixelRGBA8 124 252 0 255) 76 | , ("lemonchiffon" , PixelRGBA8 255 250 205 255) 77 | , ("lightblue" , PixelRGBA8 173 216 230 255) 78 | , ("lightcoral" , PixelRGBA8 240 128 128 255) 79 | , ("lightcyan" , PixelRGBA8 224 255 255 255) 80 | , ("lightgoldenrodyellow", PixelRGBA8 250 250 210 255) 81 | , ("lightgray" , PixelRGBA8 211 211 211 255) 82 | , ("lightgreen" , PixelRGBA8 144 238 144 255) 83 | , ("lightgrey" , PixelRGBA8 211 211 211 255) 84 | , ("lightpink" , PixelRGBA8 255 182 193 255) 85 | , ("lightsalmon" , PixelRGBA8 255 160 122 255) 86 | , ("lightseagreen" , PixelRGBA8 32 178 170 255) 87 | , ("lightskyblue" , PixelRGBA8 135 206 250 255) 88 | , ("lightslategray" , PixelRGBA8 119 136 153 255) 89 | , ("lightslategrey" , PixelRGBA8 119 136 153 255) 90 | , ("lightsteelblue" , PixelRGBA8 176 196 222 255) 91 | , ("lightyellow" , PixelRGBA8 255 255 224 255) 92 | , ("lime" , PixelRGBA8 0 255 0 255) 93 | , ("limegreen" , PixelRGBA8 50 205 50 255) 94 | , ("linen" , PixelRGBA8 250 240 230 255) 95 | , ("magenta" , PixelRGBA8 255 0 255 255) 96 | , ("maroon" , PixelRGBA8 128 0 0 255) 97 | , ("mediumaquamarine" , PixelRGBA8 102 205 170 255) 98 | , ("mediumblue" , PixelRGBA8 0 0 205 255) 99 | , ("mediumorchid" , PixelRGBA8 186 85 211 255) 100 | , ("mediumpurple" , PixelRGBA8 147 112 219 255) 101 | , ("mediumseagreen" , PixelRGBA8 60 179 113 255) 102 | , ("mediumslateblue" , PixelRGBA8 123 104 238 255) 103 | , ("mediumspringgreen" , PixelRGBA8 0 250 154 255) 104 | , ("mediumturquoise" , PixelRGBA8 72 209 204 255) 105 | , ("mediumvioletred" , PixelRGBA8 199 21 133 255) 106 | , ("midnightblue" , PixelRGBA8 25 25 112 255) 107 | , ("mintcream" , PixelRGBA8 245 255 250 255) 108 | , ("mistyrose" , PixelRGBA8 255 228 225 255) 109 | , ("moccasin" , PixelRGBA8 255 228 181 255) 110 | , ("navajowhite" , PixelRGBA8 255 222 173 255) 111 | , ("navy" , PixelRGBA8 0 0 128 255) 112 | , ("oldlace" , PixelRGBA8 253 245 230 255) 113 | , ("olive" , PixelRGBA8 128 128 0 255) 114 | , ("olivedrab" , PixelRGBA8 107 142 35 255) 115 | , ("orange" , PixelRGBA8 255 165 0 255) 116 | , ("orangered" , PixelRGBA8 255 69 0 255) 117 | , ("orchid" , PixelRGBA8 218 112 214 255) 118 | , ("palegoldenrod" , PixelRGBA8 238 232 170 255) 119 | , ("palegreen" , PixelRGBA8 152 251 152 255) 120 | , ("paleturquoise" , PixelRGBA8 175 238 238 255) 121 | , ("palevioletred" , PixelRGBA8 219 112 147 255) 122 | , ("papayawhip" , PixelRGBA8 255 239 213 255) 123 | , ("peachpuff" , PixelRGBA8 255 218 185 255) 124 | , ("peru" , PixelRGBA8 205 133 63 255) 125 | , ("pink" , PixelRGBA8 255 192 203 255) 126 | , ("plum" , PixelRGBA8 221 160 221 255) 127 | , ("powderblue" , PixelRGBA8 176 224 230 255) 128 | , ("purple" , PixelRGBA8 128 0 128 255) 129 | , ("red" , PixelRGBA8 255 0 0 255) 130 | , ("rosybrown" , PixelRGBA8 188 143 143 255) 131 | , ("royalblue" , PixelRGBA8 65 105 225 255) 132 | , ("saddlebrown" , PixelRGBA8 139 69 19 255) 133 | , ("salmon" , PixelRGBA8 250 128 114 255) 134 | , ("sandybrown" , PixelRGBA8 244 164 96 255) 135 | , ("seagreen" , PixelRGBA8 46 139 87 255) 136 | , ("seashell" , PixelRGBA8 255 245 238 255) 137 | , ("sienna" , PixelRGBA8 160 82 45 255) 138 | , ("silver" , PixelRGBA8 192 192 192 255) 139 | , ("skyblue" , PixelRGBA8 135 206 235 255) 140 | , ("slateblue" , PixelRGBA8 106 90 205 255) 141 | , ("slategray" , PixelRGBA8 112 128 144 255) 142 | , ("slategrey" , PixelRGBA8 112 128 144 255) 143 | , ("snow" , PixelRGBA8 255 250 250 255) 144 | , ("springgreen" , PixelRGBA8 0 255 127 255) 145 | , ("steelblue" , PixelRGBA8 70 130 180 255) 146 | , ("tan" , PixelRGBA8 210 180 140 255) 147 | , ("teal" , PixelRGBA8 0 128 128 255) 148 | , ("thistle" , PixelRGBA8 216 191 216 255) 149 | , ("tomato" , PixelRGBA8 255 99 71 255) 150 | , ("turquoise" , PixelRGBA8 64 224 208 255) 151 | , ("violet" , PixelRGBA8 238 130 238 255) 152 | , ("wheat" , PixelRGBA8 245 222 179 255) 153 | , ("white" , PixelRGBA8 255 255 255 255) 154 | , ("whitesmoke" , PixelRGBA8 245 245 245 255) 155 | , ("yellow" , PixelRGBA8 255 255 0 255) 156 | , ("yellowgreen" , PixelRGBA8 154 205 50 255) 157 | ] 158 | 159 | -------------------------------------------------------------------------------- /src/Graphics/Svg/PathParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | module Graphics.Svg.PathParser( transformParser 4 | , command 5 | , pathParser 6 | , viewBoxParser 7 | , pointData 8 | , gradientCommand 9 | , serializePoints 10 | , serializeCommand 11 | , serializeGradientCommand 12 | , serializeCommands 13 | , serializeViewBox 14 | ) where 15 | 16 | #if !MIN_VERSION_base(4,8,0) 17 | import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) ) 18 | #endif 19 | 20 | import Control.Applicative( (<|>) ) 21 | import Data.Scientific( toRealFloat ) 22 | import Data.Attoparsec.Text 23 | ( Parser 24 | , scientific 25 | , string 26 | , skipSpace 27 | , char 28 | , many1 29 | , digit 30 | , parseOnly 31 | ) 32 | import Data.Attoparsec.Combinator( option 33 | , sepBy 34 | , sepBy1 ) 35 | 36 | import Linear hiding ( angle, point ) 37 | import Graphics.Svg.Types 38 | import qualified Data.Text as T 39 | import Text.Printf( printf ) 40 | 41 | num :: Parser Double 42 | num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) 43 | where doubleNumber :: Parser Double 44 | doubleNumber = toRealFloat <$> scientific <|> shorthand 45 | 46 | plusMinus = negate <$ string "-" <*> doubleNumber 47 | <|> string "+" *> doubleNumber 48 | <|> doubleNumber 49 | 50 | shorthand = process' <$> (string "." *> many1 digit) 51 | process' = either (const 0) id . parseOnly doubleNumber . T.pack . (++) "0." 52 | 53 | viewBoxParser :: Parser (Double, Double, Double, Double) 54 | viewBoxParser = (,,,) 55 | <$> iParse <*> iParse <*> iParse <*> iParse 56 | where 57 | iParse = num <* skipSpace 58 | 59 | serializeViewBox :: (Double, Double, Double, Double) -> String 60 | serializeViewBox (a, b, c, d) = printf "%g %g %g %g" a b c d 61 | 62 | commaWsp :: Parser () 63 | commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace 64 | 65 | point :: Parser RPoint 66 | point = V2 <$> num <* commaWsp <*> num 67 | 68 | pointData :: Parser [RPoint] 69 | pointData = point `sepBy` commaWsp 70 | 71 | pathParser :: Parser [PathCommand] 72 | pathParser = skipSpace *> many1 command 73 | 74 | command :: Parser PathCommand 75 | command = (MoveTo OriginAbsolute <$ string "M" <*> pointList) 76 | <|> (MoveTo OriginRelative <$ string "m" <*> pointList) 77 | <|> (LineTo OriginAbsolute <$ string "L" <*> pointList) 78 | <|> (LineTo OriginRelative <$ string "l" <*> pointList) 79 | <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList) 80 | <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList) 81 | <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList) 82 | <|> (VerticalTo OriginRelative <$ string "v" <*> coordList) 83 | <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs) 84 | <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs) 85 | <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList) 86 | <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList) 87 | <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList) 88 | <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList) 89 | <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList) 90 | <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList) 91 | <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs) 92 | <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs) 93 | <|> (EndPath <$ string "Z" <* commaWsp) 94 | <|> (EndPath <$ string "z" <* commaWsp) 95 | where pointList = point `sepBy1` commaWsp 96 | pointPair = (,) <$> point <* commaWsp <*> point 97 | pointPairList = pointPair `sepBy1` commaWsp 98 | coordList = num `sepBy1` commaWsp 99 | curveToArgs = (,,) <$> (point <* commaWsp) 100 | <*> (point <* commaWsp) 101 | <*> point 102 | manyComma a = a `sepBy1` commaWsp 103 | 104 | numComma = num <* commaWsp 105 | ellipticalArgs = (,,,,,) <$> numComma 106 | <*> numComma 107 | <*> numComma 108 | <*> (fmap (/= 0) numComma) 109 | <*> (fmap (/= 0) numComma) 110 | <*> point 111 | 112 | serializePoint :: RPoint -> String 113 | serializePoint (V2 x y) = printf "%g,%g" x y 114 | 115 | serializePoints :: [RPoint] -> String 116 | serializePoints = unwords . fmap serializePoint 117 | 118 | serializeCoords :: [Coord] -> String 119 | serializeCoords = unwords . fmap (printf "%g") 120 | 121 | serializePointPair :: (RPoint, RPoint) -> String 122 | serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b 123 | 124 | serializePointPairs :: [(RPoint, RPoint)] -> String 125 | serializePointPairs = unwords . fmap serializePointPair 126 | 127 | serializePointTriplet :: (RPoint, RPoint, RPoint) -> String 128 | serializePointTriplet (a, b, c) = 129 | serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c 130 | 131 | serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String 132 | serializePointTriplets = unwords . fmap serializePointTriplet 133 | 134 | serializeCommands :: [PathCommand] -> String 135 | serializeCommands = unwords . fmap serializeCommand 136 | 137 | serializeCommand :: PathCommand -> String 138 | serializeCommand p = case p of 139 | MoveTo OriginAbsolute points -> "M" ++ serializePoints points 140 | MoveTo OriginRelative points -> "m" ++ serializePoints points 141 | LineTo OriginAbsolute points -> "L" ++ serializePoints points 142 | LineTo OriginRelative points -> "l" ++ serializePoints points 143 | 144 | HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords 145 | HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords 146 | VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords 147 | VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords 148 | 149 | CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets 150 | CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets 151 | SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs 152 | SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs 153 | QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs 154 | QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs 155 | SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points 156 | SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points 157 | EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args 158 | EllipticalArc OriginRelative args -> "a" ++ serializeArgs args 159 | EndPath -> "Z" 160 | where 161 | serializeArg (a, b, c, d, e, V2 x y) = 162 | printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y 163 | serializeArgs = unwords . fmap serializeArg 164 | 165 | 166 | 167 | transformParser :: Parser Transformation 168 | transformParser = matrixParser 169 | <|> translationParser 170 | <|> scaleParser 171 | <|> rotateParser 172 | <|> skewYParser 173 | <|> skewXParser 174 | 175 | functionParser :: T.Text -> Parser [Double] 176 | functionParser funcName = 177 | string funcName *> skipSpace 178 | *> char '(' *> skipSpace 179 | *> num `sepBy1` commaWsp 180 | <* skipSpace <* char ')' <* skipSpace 181 | 182 | translationParser :: Parser Transformation 183 | translationParser = do 184 | args <- functionParser "translate" 185 | return $ case args of 186 | [x] -> Translate x 0 187 | [x, y] -> Translate x y 188 | _ -> TransformUnknown 189 | 190 | skewXParser :: Parser Transformation 191 | skewXParser = do 192 | args <- functionParser "skewX" 193 | return $ case args of 194 | [x] -> SkewX x 195 | _ -> TransformUnknown 196 | 197 | skewYParser :: Parser Transformation 198 | skewYParser = do 199 | args <- functionParser "skewY" 200 | return $ case args of 201 | [x] -> SkewY x 202 | _ -> TransformUnknown 203 | 204 | 205 | scaleParser :: Parser Transformation 206 | scaleParser = do 207 | args <- functionParser "scale" 208 | return $ case args of 209 | [x] -> Scale x Nothing 210 | [x, y] -> Scale x (Just y) 211 | _ -> TransformUnknown 212 | 213 | matrixParser :: Parser Transformation 214 | matrixParser = do 215 | args <- functionParser "matrix" 216 | return $ case args of 217 | [a, b, c, d, e, f] -> 218 | TransformMatrix a b c d e f 219 | _ -> TransformUnknown 220 | 221 | rotateParser :: Parser Transformation 222 | rotateParser = do 223 | args <- functionParser "rotate" 224 | return $ case args of 225 | [angle] -> Rotate angle Nothing 226 | [angle, x, y] -> Rotate angle $ Just (x, y) 227 | _ -> TransformUnknown 228 | {- 229 | rotate( [ ]), which specifies a rotation by degrees about a given point. 230 | 231 | 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]. 232 | 233 | 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(-, -). 234 | 235 | skewX(), which specifies a skew transformation along the x-axis. 236 | 237 | skewY(), which specifies a skew transformation along the y-axis. 238 | -} 239 | gradientCommand :: Parser GradientPathCommand 240 | gradientCommand = 241 | (GLine OriginAbsolute <$> (string "L" *> mayPoint)) 242 | <|> (GLine OriginRelative <$> (string "l" *> mayPoint)) 243 | <|> (string "C" *> curveToArgs OriginAbsolute) 244 | <|> (string "c" *> curveToArgs OriginRelative) 245 | <|> (GClose <$ string "Z") 246 | where 247 | mayPoint = option Nothing $ Just <$> point 248 | curveToArgs o = 249 | GCurve o <$> (point <* commaWsp) 250 | <*> (point <* commaWsp) 251 | <*> mayPoint 252 | 253 | serializeGradientCommand :: GradientPathCommand -> String 254 | serializeGradientCommand p = case p of 255 | GLine OriginAbsolute points -> "L" ++ smp points 256 | GLine OriginRelative points -> "l" ++ smp points 257 | GClose -> "Z" 258 | 259 | GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c 260 | GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c 261 | where 262 | sp = serializePoint 263 | smp Nothing = "" 264 | smp (Just pp) = serializePoint pp 265 | -------------------------------------------------------------------------------- /src/Graphics/Svg/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE CPP #-} 7 | -- | This module define all the types used in the definition 8 | -- of a svg scene. 9 | -- 10 | -- Most of the types are lensified. 11 | module Graphics.Svg.Types 12 | ( -- * Basic building types 13 | Coord 14 | , Origin( .. ) 15 | , Point 16 | , RPoint 17 | , PathCommand( .. ) 18 | , Transformation( .. ) 19 | , ElementRef( .. ) 20 | , CoordinateUnits( .. ) 21 | 22 | -- ** Building helpers 23 | , toPoint 24 | , serializeNumber 25 | , serializeTransformation 26 | , serializeTransformations 27 | 28 | -- * Drawing control types 29 | , Cap( .. ) 30 | , LineJoin( .. ) 31 | , Tree( .. ) 32 | , Number( .. ) 33 | , Spread( .. ) 34 | , Texture( .. ) 35 | , Element( .. ) 36 | , FillRule( .. ) 37 | , FontStyle( .. ) 38 | , Dpi 39 | 40 | , WithDefaultSvg( .. ) 41 | 42 | -- * Main type 43 | , Document( .. ) 44 | , HasDocument( .. ) 45 | , documentSize 46 | 47 | -- * Drawing attributes 48 | , DrawAttributes( .. ) 49 | , HasDrawAttributes( .. ) 50 | , WithDrawAttributes( .. ) 51 | 52 | -- * SVG drawing primitives 53 | -- ** Rectangle 54 | , Rectangle( .. ) 55 | , HasRectangle( .. ) 56 | 57 | -- ** Line 58 | , Line( .. ) 59 | , HasLine( .. ) 60 | 61 | -- ** Polygon 62 | , Polygon( .. ) 63 | , HasPolygon( .. ) 64 | 65 | -- ** Polyline 66 | , PolyLine( .. ) 67 | , HasPolyLine( .. ) 68 | 69 | -- ** Path 70 | , Path( .. ) 71 | , HasPath( .. ) 72 | 73 | -- ** Circle 74 | , Circle( .. ) 75 | , HasCircle( .. ) 76 | 77 | -- ** Ellipse 78 | , Ellipse( .. ) 79 | , HasEllipse( .. ) 80 | 81 | -- ** Mesh (gradient mesh) 82 | , GradientPathCommand( .. ) 83 | , MeshGradientType( .. ) 84 | 85 | , MeshGradient( .. ) 86 | , HasMeshGradient( .. ) 87 | 88 | , MeshGradientRow( .. ) 89 | , HasMeshGradientRow( .. ) 90 | 91 | , MeshGradientPatch( .. ) 92 | , HasMeshGradientPatch( .. ) 93 | 94 | -- ** Image 95 | , Image( .. ) 96 | , HasImage( .. ) 97 | 98 | -- ** Use 99 | , Use( .. ) 100 | , HasUse( .. ) 101 | 102 | -- * Grouping primitives 103 | -- ** Group 104 | , Group( .. ) 105 | , HasGroup( .. ) 106 | 107 | -- ** Symbol 108 | , Symbol( .. ) 109 | , groupOfSymbol 110 | 111 | -- * Text related types 112 | -- ** Text 113 | , Text( .. ) 114 | , HasText( .. ) 115 | , TextAnchor( .. ) 116 | , textAt 117 | 118 | -- ** Text path 119 | , TextPath( .. ) 120 | , HasTextPath( .. ) 121 | 122 | , TextPathSpacing( .. ) 123 | , TextPathMethod( .. ) 124 | 125 | -- ** Text span. 126 | , TextSpanContent( .. ) 127 | 128 | , TextSpan( .. ) 129 | , HasTextSpan( .. ) 130 | 131 | , TextInfo( .. ) 132 | , HasTextInfo( .. ) 133 | 134 | , TextAdjust( .. ) 135 | 136 | -- * Marker definition 137 | , Marker( .. ) 138 | , Overflow( .. ) 139 | , MarkerOrientation( .. ) 140 | , MarkerUnit( .. ) 141 | , HasMarker( .. ) 142 | 143 | -- * Gradient definition 144 | , GradientStop( .. ) 145 | , HasGradientStop( .. ) 146 | 147 | -- ** Linear Gradient 148 | , LinearGradient( .. ) 149 | , HasLinearGradient( .. ) 150 | 151 | -- ** Radial Gradient 152 | , RadialGradient( .. ) 153 | , HasRadialGradient( .. ) 154 | 155 | -- * Pattern definition 156 | , Pattern( .. ) 157 | , HasPattern( .. ) 158 | 159 | -- * Mask definition 160 | , Mask( .. ) 161 | , HasMask( .. ) 162 | 163 | -- * Clip path definition 164 | , ClipPath( .. ) 165 | , HasClipPath( .. ) 166 | 167 | -- * Aspect Ratio description 168 | , PreserveAspectRatio( .. ) 169 | , Alignment( .. ) 170 | , MeetSlice( .. ) 171 | , HasPreserveAspectRatio( .. ) 172 | 173 | -- * MISC functions 174 | , isPathArc 175 | , isPathWithArc 176 | , nameOfTree 177 | , zipTree 178 | , mapTree 179 | , foldTree 180 | , toUserUnit 181 | , mapNumber 182 | ) where 183 | 184 | #if !MIN_VERSION_base(4,8,0) 185 | import Data.Monoid( Monoid( .. ) ) 186 | import Data.Foldable( Foldable ) 187 | #endif 188 | 189 | import Data.Function( on ) 190 | import Data.List( inits ) 191 | import qualified Data.Map as M 192 | import Data.Semigroup( Semigroup( .. ) ) 193 | import Data.Monoid( Last( .. ) ) 194 | import qualified Data.Foldable as F 195 | import qualified Data.Text as T 196 | import Codec.Picture( PixelRGBA8( .. ) ) 197 | import Control.Lens( Lens' 198 | , Lens 199 | , lens 200 | , view 201 | , (^.) 202 | , (&) 203 | , (.~) 204 | ) 205 | import Graphics.Svg.CssTypes 206 | import Linear hiding ( angle ) 207 | 208 | import Text.Printf 209 | 210 | -- | Basic coordinate type. 211 | type Coord = Double 212 | 213 | -- | Real Point, fully determined and not 214 | -- dependant of the rendering context. 215 | type RPoint = V2 Coord 216 | 217 | -- | Possibly context dependant point. 218 | type Point = (Number, Number) 219 | 220 | -- | Tell if a path command is absolute (in the current 221 | -- user coordiante) or relative to the previous poitn. 222 | data Origin 223 | = OriginAbsolute -- ^ Next point in absolute coordinate 224 | | OriginRelative -- ^ Next point relative to the previous 225 | deriving (Eq, Show) 226 | 227 | data MeshGradientType 228 | = GradientBilinear 229 | | GradientBicubic 230 | deriving (Eq, Show) 231 | 232 | -- | Path command definition. 233 | data PathCommand 234 | -- | 'M' or 'm' command 235 | = MoveTo !Origin ![RPoint] 236 | -- | Line to, 'L' or 'l' Svg path command. 237 | | LineTo !Origin ![RPoint] 238 | 239 | -- | Equivalent to the 'H' or 'h' svg path command. 240 | | HorizontalTo !Origin ![Coord] 241 | -- | Equivalent to the 'V' or 'v' svg path command. 242 | | VerticalTo !Origin ![Coord] 243 | 244 | -- | Cubic bezier, 'C' or 'c' command 245 | | CurveTo !Origin ![(RPoint, RPoint, RPoint)] 246 | -- | Smooth cubic bezier, equivalent to 'S' or 's' command 247 | | SmoothCurveTo !Origin ![(RPoint, RPoint)] 248 | -- | Quadratic bezier, 'Q' or 'q' command 249 | | QuadraticBezier !Origin ![(RPoint, RPoint)] 250 | -- | Quadratic bezier, 'T' or 't' command 251 | | SmoothQuadraticBezierCurveTo !Origin ![RPoint] 252 | -- | Eliptical arc, 'A' or 'a' command. 253 | | EllipticalArc !Origin ![(Coord, Coord, Coord, Bool, Bool, RPoint)] 254 | -- | Close the path, 'Z' or 'z' svg path command. 255 | | EndPath 256 | deriving (Eq, Show) 257 | 258 | -- | Description of path used in meshgradient tag 259 | data GradientPathCommand 260 | -- | Line to, 'L' or 'l' Svg path command. 261 | = GLine !Origin !(Maybe RPoint) 262 | -- | Cubic bezier, 'C' or 'c' command 263 | | GCurve !Origin !RPoint !RPoint !(Maybe RPoint) 264 | -- | 'Z' command 265 | | GClose 266 | deriving (Eq, Show) 267 | 268 | -- | Little helper function to build a point. 269 | toPoint :: Number -> Number -> Point 270 | toPoint = (,) 271 | 272 | -- | Tell if the path command is an EllipticalArc. 273 | isPathArc :: PathCommand -> Bool 274 | isPathArc (EllipticalArc _ _) = True 275 | isPathArc _ = False 276 | 277 | -- | Tell if a full path contain an EllipticalArc. 278 | isPathWithArc :: Foldable f => f PathCommand -> Bool 279 | isPathWithArc = F.any isPathArc 280 | 281 | -- | Define the possible values of various *units attributes 282 | -- used in the definition of the gradients and masks. 283 | data CoordinateUnits 284 | = CoordUserSpace -- ^ `userSpaceOnUse` value 285 | | CoordBoundingBox -- ^ `objectBoundingBox` value 286 | deriving (Eq, Show) 287 | 288 | -- | This type represent the align information of the 289 | -- preserveAspectRatio SVGattribute 290 | data Alignment 291 | = AlignNone -- ^ "none" value 292 | | AlignxMinYMin -- "xMinYMin" value 293 | | AlignxMidYMin -- ^ "xMidYMin" value 294 | | AlignxMaxYMin -- ^ "xMaxYMin" value 295 | | AlignxMinYMid -- ^ "xMinYMid" value 296 | | AlignxMidYMid -- ^ "xMidYMid" value 297 | | AlignxMaxYMid -- ^ "xMaxYMid" value 298 | | AlignxMinYMax -- ^ "xMinYMax" value 299 | | AlignxMidYMax -- ^ "xMidYMax" value 300 | | AlignxMaxYMax -- ^ "xMaxYMax" value 301 | deriving (Eq, Show) 302 | 303 | -- | This type represent the "meet or slice" information 304 | -- of the preserveAspectRatio SVGattribute 305 | data MeetSlice = Meet | Slice 306 | deriving (Eq, Show) 307 | 308 | -- | Describe the content of the preserveAspectRatio attribute. 309 | data PreserveAspectRatio = PreserveAspectRatio 310 | { _aspectRatioDefer :: !Bool 311 | , _aspectRatioAlign :: !Alignment 312 | , _aspectRatioMeetSlice :: !(Maybe MeetSlice) 313 | } 314 | deriving (Eq, Show) 315 | 316 | instance WithDefaultSvg PreserveAspectRatio where 317 | defaultSvg = PreserveAspectRatio 318 | { _aspectRatioDefer = False 319 | , _aspectRatioAlign = AlignxMidYMid 320 | , _aspectRatioMeetSlice = Nothing 321 | } 322 | 323 | -- | Describe how the line should be terminated 324 | -- when stroking them. Describe the values of the 325 | -- `stroke-linecap` attribute. 326 | -- See `_strokeLineCap` 327 | data Cap 328 | = CapRound -- ^ End with a round (`round` value) 329 | | CapButt -- ^ Define straight just at the end (`butt` value) 330 | | CapSquare -- ^ Straight further of the ends (`square` value) 331 | deriving (Eq, Show) 332 | 333 | -- | Define the possible values of the `stroke-linejoin` 334 | -- attribute. 335 | -- see `_strokeLineJoin` 336 | data LineJoin 337 | = JoinMiter -- ^ `miter` value 338 | | JoinBevel -- ^ `bevel` value 339 | | JoinRound -- ^ `round` value 340 | deriving (Eq, Show) 341 | 342 | -- | Describe the different value which can be used 343 | -- in the `fill` or `stroke` attributes. 344 | data Texture 345 | = ColorRef PixelRGBA8 -- ^ Direct solid color (#rrggbb, #rgb) 346 | | TextureRef String -- ^ Link to a complex texture (url(#name)) 347 | | FillNone -- ^ Equivalent to the `none` value. 348 | deriving (Eq, Show) 349 | 350 | -- | Describe the possile filling algorithms. 351 | -- Map the values of the `fill-rule` attributes. 352 | data FillRule 353 | = FillEvenOdd -- ^ Correspond to the `evenodd` value. 354 | | FillNonZero -- ^ Correspond to the `nonzero` value. 355 | deriving (Eq, Show) 356 | 357 | -- | Describe the content of the `transformation` attribute. 358 | -- see `_transform` and `transform`. 359 | data Transformation 360 | = -- | Directly encode the translation matrix. 361 | TransformMatrix !Coord !Coord !Coord 362 | !Coord !Coord !Coord 363 | -- | Translation along a vector 364 | | Translate !Double !Double 365 | -- | Scaling on both axis or on X axis and Y axis. 366 | | Scale !Double !(Maybe Double) 367 | -- | Rotation around `(0, 0)` or around an optional 368 | -- point. 369 | | Rotate !Double !(Maybe (Double, Double)) 370 | -- | Skew transformation along the X axis. 371 | | SkewX !Double 372 | -- | Skew transformation along the Y axis. 373 | | SkewY !Double 374 | -- | Unkown transformation, like identity. 375 | | TransformUnknown 376 | deriving (Eq, Show) 377 | 378 | -- | Convert the Transformation to a string which can be 379 | -- directly used in a svg attributes. 380 | serializeTransformation :: Transformation -> String 381 | serializeTransformation t = case t of 382 | TransformUnknown -> "" 383 | TransformMatrix a b c d e f -> 384 | printf "matrix(%g, %g, %g, %g, %g, %g)" a b c d e f 385 | Translate x y -> printf "translate(%g, %g)" x y 386 | Scale x Nothing -> printf "scale(%g)" x 387 | Scale x (Just y) -> printf "scale(%g, %g)" x y 388 | Rotate angle Nothing -> printf "rotate(%g)" angle 389 | Rotate angle (Just (x, y))-> printf "rotate(%g, %g, %g)" angle x y 390 | SkewX x -> printf "skewX(%g)" x 391 | SkewY y -> printf "skewY(%g)" y 392 | 393 | -- | Transform a list of transformations to a string for svg 394 | -- `transform` attributes. 395 | serializeTransformations :: [Transformation] -> String 396 | serializeTransformations = 397 | unwords . fmap serializeTransformation 398 | 399 | -- | Class helping find the drawing attributes for all 400 | -- the SVG attributes. 401 | class WithDrawAttributes a where 402 | -- | Lens which can be used to read/write primitives. 403 | drawAttr :: Lens' a DrawAttributes 404 | 405 | -- | Define an empty 'default' element for the SVG tree. 406 | -- It is used as base when parsing the element from XML. 407 | class WithDefaultSvg a where 408 | -- | The default element. 409 | defaultSvg :: a 410 | 411 | -- | Classify the font style, used to search a matching 412 | -- font in the FontCache. 413 | data FontStyle 414 | = FontStyleNormal 415 | | FontStyleItalic 416 | | FontStyleOblique 417 | deriving (Eq, Show) 418 | 419 | -- | Tell where to anchor the text, where the position 420 | -- given is realative to the text. 421 | data TextAnchor 422 | -- | The text with left aligned, or start at the postion 423 | -- If the point is the '*' then the text will be printed 424 | -- this way: 425 | -- 426 | -- > *THE_TEXT_TO_PRINT 427 | -- 428 | -- Equivalent to the `start` value. 429 | = TextAnchorStart 430 | -- | The text is middle aligned, so the text will be at 431 | -- the left and right of the position: 432 | -- 433 | -- > THE_TEXT*TO_PRINT 434 | -- 435 | -- Equivalent to the `middle` value. 436 | | TextAnchorMiddle 437 | -- | The text is right aligned. 438 | -- 439 | -- > THE_TEXT_TO_PRINT* 440 | -- 441 | -- Equivalent to the `end` value. 442 | | TextAnchorEnd 443 | deriving (Eq, Show) 444 | 445 | 446 | -- | Correspond to the possible values of the 447 | -- the attributes which are either `none` or 448 | -- `url(#elem)` 449 | data ElementRef 450 | = RefNone -- ^ Value for `none` 451 | | Ref String -- ^ Equivalent to `url()` attribute. 452 | deriving (Eq, Show) 453 | 454 | -- | This type define how to draw any primitives, 455 | -- which color to use, how to stroke the primitives 456 | -- and the potential transformations to use. 457 | -- 458 | -- All these attributes are propagated to the children. 459 | data DrawAttributes = DrawAttributes 460 | { -- | Attribute corresponding to the `stroke-width` 461 | -- SVG attribute. 462 | _strokeWidth :: !(Last Number) 463 | -- | Correspond to the `stroke` attribute. 464 | , _strokeColor :: !(Last Texture) 465 | -- | Define the `stroke-opacity` attribute, the transparency 466 | -- for the "border". 467 | , _strokeOpacity :: !(Maybe Float) 468 | -- | Correspond to the `stroke-linecap` SVG 469 | -- attribute 470 | , _strokeLineCap :: !(Last Cap) 471 | -- | Correspond to the `stroke-linejoin` SVG 472 | -- attribute 473 | , _strokeLineJoin :: !(Last LineJoin) 474 | -- | Define the distance of the miter join, correspond 475 | -- to the `stroke-miterlimit` attritbue. 476 | , _strokeMiterLimit :: !(Last Double) 477 | -- | Define the filling color of the elements. Corresponding 478 | -- to the `fill` attribute. 479 | , _fillColor :: !(Last Texture) 480 | -- | Define the `fill-opacity` attribute, the transparency 481 | -- for the "content". 482 | , _fillOpacity :: !(Maybe Float) 483 | -- | Define the global or group opacity attribute. 484 | , _groupOpacity :: !(Maybe Float) 485 | -- | Content of the `transform` attribute 486 | , _transform :: !(Maybe [Transformation]) 487 | -- | Define the `fill-rule` used during the rendering. 488 | , _fillRule :: !(Last FillRule) 489 | -- | Define the `mask` attribute. 490 | , _maskRef :: !(Last ElementRef) 491 | -- | Define the `clip-path` attribute. 492 | , _clipPathRef :: !(Last ElementRef) 493 | -- | Define the `clip-rule` attribute. 494 | , _clipRule :: !(Last FillRule) 495 | -- | Map to the `class` attribute. Used for the CSS 496 | -- rewriting. 497 | , _attrClass :: ![T.Text] 498 | -- | Map to the `id` attribute. Used for the CSS 499 | -- rewriting. 500 | , _attrId :: !(Maybe String) 501 | -- | Define the start distance of the dashing pattern. 502 | -- Correspond to the `stroke-dashoffset` attribute. 503 | , _strokeOffset :: !(Last Number) 504 | -- | Define the dashing pattern for the lines. Correspond 505 | -- to the `stroke-dasharray` attribute. 506 | , _strokeDashArray :: !(Last [Number]) 507 | -- | Current size of the text, correspond to the 508 | -- `font-size` SVG attribute. 509 | , _fontSize :: !(Last Number) 510 | -- | Define the possible fonts to be used for text rendering. 511 | -- Map to the `font-family` attribute. 512 | , _fontFamily :: !(Last [String]) 513 | -- | Map to the `font-style` attribute. 514 | , _fontStyle :: !(Last FontStyle) 515 | -- | Define how to interpret the text position, correspond 516 | -- to the `text-anchor` attribute. 517 | , _textAnchor :: !(Last TextAnchor) 518 | -- | Define the marker used for the start of the line. 519 | -- Correspond to the `marker-start` attribute. 520 | , _markerStart :: !(Last ElementRef) 521 | -- | Define the marker used for every point of the 522 | -- polyline/path Correspond to the `marker-mid` 523 | -- attribute. 524 | , _markerMid :: !(Last ElementRef) 525 | -- | Define the marker used for the end of the line. 526 | -- Correspond to the `marker-end` attribute. 527 | , _markerEnd :: !(Last ElementRef) 528 | } 529 | deriving (Eq, Show) 530 | 531 | 532 | -- | This primitive describe an unclosed suite of 533 | -- segments. Correspond to the `` tag. 534 | data PolyLine = PolyLine 535 | { -- | drawing attributes of the polyline. 536 | _polyLineDrawAttributes :: !DrawAttributes 537 | 538 | -- | Geometry definition of the polyline. 539 | -- correspond to the `points` attribute 540 | , _polyLinePoints :: ![RPoint] 541 | } 542 | deriving (Eq, Show) 543 | 544 | 545 | instance WithDefaultSvg PolyLine where 546 | defaultSvg = PolyLine 547 | { _polyLineDrawAttributes = mempty 548 | , _polyLinePoints = [] 549 | } 550 | 551 | -- makeClassy ''PolyLine 552 | -- | Lenses for the PolyLine type. 553 | class HasPolyLine a where 554 | polyLine :: Lens' a PolyLine 555 | polyLineDrawAttributes :: Lens' a DrawAttributes 556 | {-# INLINE polyLineDrawAttributes #-} 557 | polyLineDrawAttributes = polyLine . polyLineDrawAttributes 558 | 559 | polyLinePoints :: Lens' a [RPoint] 560 | {-# INLINE polyLinePoints #-} 561 | polyLinePoints = polyLine . polyLinePoints 562 | 563 | instance HasPolyLine PolyLine where 564 | polyLine = id 565 | {-# INLINE polyLineDrawAttributes #-} 566 | polyLineDrawAttributes f p = 567 | fmap (\y -> p { _polyLineDrawAttributes = y }) (f $ _polyLineDrawAttributes p) 568 | {-# INLINE polyLinePoints #-} 569 | polyLinePoints f p = 570 | fmap (\y -> p { _polyLinePoints = y }) (f $ _polyLinePoints p) 571 | 572 | instance WithDrawAttributes PolyLine where 573 | drawAttr = polyLineDrawAttributes 574 | 575 | -- | Primitive decriving polygon composed 576 | -- of segements. Correspond to the `` 577 | -- tag 578 | data Polygon = Polygon 579 | { -- | Drawing attributes for the polygon. 580 | _polygonDrawAttributes :: !DrawAttributes 581 | -- | Points of the polygon. Correspond to 582 | -- the `points` attributes. 583 | , _polygonPoints :: ![RPoint] 584 | } 585 | deriving (Eq, Show) 586 | 587 | -- makeClassy ''Polygon 588 | -- | Lenses for the Polygon type 589 | class HasPolygon a where 590 | polygon :: Lens' a Polygon 591 | polygonDrawAttributes :: Lens' a DrawAttributes 592 | {-# INLINE polygonDrawAttributes #-} 593 | polygonPoints :: Lens' a [RPoint] 594 | {-# INLINE polygonPoints #-} 595 | polygonDrawAttributes = polygon . polygonDrawAttributes 596 | polygonPoints = polygon . polygonPoints 597 | 598 | instance HasPolygon Polygon where 599 | polygon = id 600 | {-# INLINE polygonDrawAttributes #-} 601 | polygonDrawAttributes f p = 602 | fmap (\y -> p { _polygonDrawAttributes = y }) (f $ _polygonDrawAttributes p) 603 | {-# INLINE polygonPoints #-} 604 | polygonPoints f p = 605 | fmap (\y -> p { _polygonPoints = y }) (f $ _polygonPoints p) 606 | 607 | instance WithDrawAttributes Polygon where 608 | drawAttr = polygonDrawAttributes 609 | 610 | instance WithDefaultSvg Polygon where 611 | defaultSvg = Polygon 612 | { _polygonDrawAttributes = mempty 613 | , _polygonPoints = [] 614 | } 615 | 616 | -- | Define a simple line. Correspond to the 617 | -- `` tag. 618 | data Line = Line 619 | { -- | Drawing attributes of line. 620 | _lineDrawAttributes :: !DrawAttributes 621 | -- | First point of the the line, correspond 622 | -- to the `x1` and `y1` attributes. 623 | , _linePoint1 :: !Point 624 | -- | Second point of the the line, correspond 625 | -- to the `x2` and `y2` attributes. 626 | , _linePoint2 :: !Point 627 | } 628 | deriving (Eq, Show) 629 | 630 | -- makeClassy ''Line 631 | -- | Lenses for the Line type. 632 | class HasLine a where 633 | line :: Lens' a Line 634 | lineDrawAttributes :: Lens' a DrawAttributes 635 | lineDrawAttributes = line . lineDrawAttributes 636 | {-# INLINE lineDrawAttributes #-} 637 | linePoint1 :: Lens' a Point 638 | linePoint1 = line . linePoint1 639 | {-# INLINE linePoint1 #-} 640 | linePoint2 :: Lens' a Point 641 | linePoint2 = line . linePoint2 642 | {-# INLINE linePoint2 #-} 643 | 644 | instance HasLine Line where 645 | line = id 646 | {-# INLINE lineDrawAttributes #-} 647 | lineDrawAttributes f l = 648 | fmap (\y -> l { _lineDrawAttributes = y }) (f (_lineDrawAttributes l)) 649 | {-# INLINE linePoint1 #-} 650 | linePoint1 f l = 651 | fmap (\y -> l { _linePoint1 = y }) (f (_linePoint1 l)) 652 | {-# INLINE linePoint2 #-} 653 | linePoint2 f l = 654 | fmap (\y -> l { _linePoint2 = y }) (f (_linePoint2 l)) 655 | 656 | instance WithDrawAttributes Line where 657 | drawAttr = lineDrawAttributes 658 | 659 | instance WithDefaultSvg Line where 660 | defaultSvg = Line 661 | { _lineDrawAttributes = mempty 662 | , _linePoint1 = zeroPoint 663 | , _linePoint2 = zeroPoint 664 | } 665 | where zeroPoint = (Num 0, Num 0) 666 | 667 | -- | Define a rectangle. Correspond to 668 | -- `` svg tag. 669 | data Rectangle = Rectangle 670 | { -- | Rectangle drawing attributes. 671 | _rectDrawAttributes :: !DrawAttributes 672 | -- | Upper left corner of the rectangle, correspond 673 | -- to the attributes `x` and `y`. 674 | , _rectUpperLeftCorner :: !Point 675 | -- | Rectangle width, correspond, strangely, to 676 | -- the `width` attribute. 677 | , _rectWidth :: !Number 678 | -- | Rectangle height, correspond, amazingly, to 679 | -- the `height` attribute. 680 | , _rectHeight :: !Number 681 | -- | Define the rounded corner radius radius 682 | -- of the rectangle. Correspond to the `rx` and 683 | -- `ry` attributes. 684 | , _rectCornerRadius :: !(Number, Number) 685 | } 686 | deriving (Eq, Show) 687 | 688 | -- makeClassy ''Rectangle 689 | -- | Lenses for the Rectangle type. 690 | class HasRectangle a where 691 | rectangle :: Lens' a Rectangle 692 | rectCornerRadius :: Lens' a (Number, Number) 693 | {-# INLINE rectCornerRadius #-} 694 | rectCornerRadius = rectangle . rectCornerRadius 695 | 696 | rectDrawAttributes :: Lens' a DrawAttributes 697 | {-# INLINE rectDrawAttributes #-} 698 | rectDrawAttributes = rectangle . rectDrawAttributes 699 | 700 | rectHeight :: Lens' a Number 701 | {-# INLINE rectHeight #-} 702 | rectHeight = rectangle . rectHeight 703 | 704 | rectUpperLeftCorner :: Lens' a Point 705 | {-# INLINE rectUpperLeftCorner #-} 706 | rectUpperLeftCorner = rectangle . rectUpperLeftCorner 707 | 708 | rectWidth :: Lens' a Number 709 | {-# INLINE rectWidth #-} 710 | rectWidth = rectangle . rectWidth 711 | 712 | instance HasRectangle Rectangle where 713 | rectangle = id 714 | {-# INLINE rectCornerRadius #-} 715 | rectCornerRadius f attr = 716 | fmap (\y -> attr { _rectCornerRadius = y }) (f $ _rectCornerRadius attr) 717 | {-# INLINE rectDrawAttributes #-} 718 | rectDrawAttributes f attr = 719 | fmap (\y -> attr { _rectDrawAttributes = y }) (f $ _rectDrawAttributes attr) 720 | {-# INLINE rectHeight #-} 721 | rectHeight f attr = 722 | fmap (\y -> attr { _rectHeight = y }) (f $ _rectHeight attr) 723 | {-# INLINE rectUpperLeftCorner #-} 724 | rectUpperLeftCorner f attr = 725 | fmap (\y -> attr { _rectUpperLeftCorner = y }) (f $ _rectUpperLeftCorner attr) 726 | {-# INLINE rectWidth #-} 727 | rectWidth f attr = 728 | fmap (\y -> attr { _rectWidth = y }) (f $ _rectWidth attr) 729 | 730 | instance WithDrawAttributes Rectangle where 731 | drawAttr = rectDrawAttributes 732 | 733 | instance WithDefaultSvg Rectangle where 734 | defaultSvg = Rectangle 735 | { _rectDrawAttributes = mempty 736 | , _rectUpperLeftCorner = (Num 0, Num 0) 737 | , _rectWidth = Num 0 738 | , _rectHeight = Num 0 739 | , _rectCornerRadius = (Num 0, Num 0) 740 | } 741 | 742 | -- | Type mapping the `` svg tag. 743 | data Path = Path 744 | { -- | Drawing attributes of the path. 745 | _pathDrawAttributes :: !DrawAttributes 746 | -- | Definition of the path, correspond to the 747 | -- `d` attributes. 748 | , _pathDefinition :: ![PathCommand] 749 | } 750 | deriving (Eq, Show) 751 | 752 | -- makeClassy ''Path 753 | -- | Lenses for the Path type 754 | class HasPath c_alhy where 755 | path :: Lens' c_alhy Path 756 | pathDefinition :: Lens' c_alhy [PathCommand] 757 | {-# INLINE pathDefinition #-} 758 | pathDefinition = path . pathDefinition 759 | 760 | pathDrawAttributes :: Lens' c_alhy DrawAttributes 761 | {-# INLINE pathDrawAttributes #-} 762 | pathDrawAttributes = path . pathDrawAttributes 763 | 764 | instance HasPath Path where 765 | path = id 766 | {-# INLINE pathDefinition #-} 767 | pathDefinition f attr = 768 | fmap (\y -> attr { _pathDefinition = y }) (f $ _pathDefinition attr) 769 | {-# INLINE pathDrawAttributes #-} 770 | pathDrawAttributes f attr = 771 | fmap (\y -> attr { _pathDrawAttributes = y }) (f $ _pathDrawAttributes attr) 772 | 773 | instance WithDrawAttributes Path where 774 | drawAttr = pathDrawAttributes 775 | 776 | instance WithDefaultSvg Path where 777 | defaultSvg = Path 778 | { _pathDrawAttributes = mempty 779 | , _pathDefinition = [] 780 | } 781 | 782 | -- | Define a SVG group, corresponding `` tag. 783 | data Group a = Group 784 | { -- | Group drawing attributes, propagated to all of its 785 | -- children. 786 | _groupDrawAttributes :: !DrawAttributes 787 | -- | Content of the group, corresponding to all the tags 788 | -- inside the `` tag. 789 | , _groupChildren :: ![a] 790 | -- | Mapped to the attribute `viewBox` 791 | , _groupViewBox :: !(Maybe (Double, Double, Double, Double)) 792 | -- | used for symbols only 793 | , _groupAspectRatio :: !PreserveAspectRatio 794 | } 795 | deriving (Eq, Show) 796 | 797 | -- makeClassy ''Group 798 | -- | Lenses associated to the Group type. 799 | class HasGroup g a | g -> a where 800 | group :: Lens' g (Group a) 801 | groupAspectRatio :: Lens' g PreserveAspectRatio 802 | {-# INLINE groupAspectRatio #-} 803 | groupAspectRatio = group . groupAspectRatio 804 | 805 | groupChildren :: Lens' g [a] 806 | {-# INLINE groupChildren #-} 807 | groupChildren = group . groupChildren 808 | 809 | groupDrawAttributes :: Lens' g DrawAttributes 810 | {-# INLINE groupDrawAttributes #-} 811 | groupDrawAttributes = group . groupDrawAttributes 812 | 813 | groupViewBox :: Lens' g (Maybe (Double, Double, Double, Double)) 814 | {-# INLINE groupViewBox #-} 815 | groupViewBox = group . groupViewBox 816 | 817 | instance HasGroup (Group a) a where 818 | group = id 819 | {-# INLINE groupAspectRatio #-} 820 | groupAspectRatio f attr = 821 | fmap (\y -> attr { _groupAspectRatio = y }) (f $ _groupAspectRatio attr) 822 | 823 | {-# INLINE groupChildren #-} 824 | groupChildren f attr = 825 | fmap (\y -> attr { _groupChildren = y }) (f $ _groupChildren attr) 826 | 827 | {-# INLINE groupDrawAttributes #-} 828 | groupDrawAttributes f attr = 829 | fmap (\y -> attr { _groupDrawAttributes = y }) (f $ _groupDrawAttributes attr) 830 | 831 | {-# INLINE groupViewBox #-} 832 | groupViewBox f attr = 833 | fmap (\y -> attr { _groupViewBox = y }) (f $ _groupViewBox attr) 834 | 835 | instance WithDrawAttributes (Group a) where 836 | drawAttr = groupDrawAttributes 837 | 838 | instance WithDefaultSvg (Group a) where 839 | defaultSvg = Group 840 | { _groupDrawAttributes = mempty 841 | , _groupChildren = [] 842 | , _groupViewBox = Nothing 843 | , _groupAspectRatio = defaultSvg 844 | } 845 | 846 | -- | Define the `` tag, equivalent to 847 | -- a named group. 848 | newtype Symbol a = 849 | Symbol { _groupOfSymbol :: Group a } 850 | deriving (Eq, Show) 851 | 852 | -- makeLenses ''Symbol 853 | -- | Lenses associated with the Symbol type. 854 | groupOfSymbol :: Lens (Symbol s) (Symbol t) (Group s) (Group t) 855 | {-# INLINE groupOfSymbol #-} 856 | groupOfSymbol f = fmap Symbol . f . _groupOfSymbol 857 | 858 | instance WithDrawAttributes (Symbol a) where 859 | drawAttr = groupOfSymbol . drawAttr 860 | 861 | instance WithDefaultSvg (Symbol a) where 862 | defaultSvg = Symbol defaultSvg 863 | 864 | -- | Define a ``. 865 | data Circle = Circle 866 | { -- | Drawing attributes of the circle. 867 | _circleDrawAttributes :: !DrawAttributes 868 | -- | Define the center of the circle, describe 869 | -- the `cx` and `cy` attributes. 870 | , _circleCenter :: !Point 871 | -- | Radius of the circle, equivalent to the `r` 872 | -- attribute. 873 | , _circleRadius :: !Number 874 | } 875 | deriving (Eq, Show) 876 | 877 | -- makeClassy ''Circle 878 | -- | Lenses for the Circle type. 879 | class HasCircle a where 880 | circle :: Lens' a Circle 881 | circleCenter :: Lens' a Point 882 | {-# INLINE circleCenter #-} 883 | circleCenter = circle . circleCenter 884 | 885 | circleDrawAttributes :: Lens' a DrawAttributes 886 | {-# INLINE circleDrawAttributes #-} 887 | circleDrawAttributes = circle . circleDrawAttributes 888 | 889 | circleRadius :: Lens' a Number 890 | {-# INLINE circleRadius #-} 891 | circleRadius = circle . circleRadius 892 | 893 | instance HasCircle Circle where 894 | circle = id 895 | {-# INLINE circleCenter #-} 896 | circleCenter f attr = 897 | fmap (\y -> attr { _circleCenter = y }) (f $ _circleCenter attr) 898 | {-# INLINE circleDrawAttributes #-} 899 | circleDrawAttributes f attr = 900 | fmap (\y -> attr { _circleDrawAttributes = y }) (f $ _circleDrawAttributes attr) 901 | {-# INLINE circleRadius #-} 902 | circleRadius f attr = 903 | fmap (\y -> attr { _circleRadius = y }) (f $ _circleRadius attr) 904 | 905 | instance WithDrawAttributes Circle where 906 | drawAttr = circleDrawAttributes 907 | 908 | instance WithDefaultSvg Circle where 909 | defaultSvg = Circle 910 | { _circleDrawAttributes = mempty 911 | , _circleCenter = (Num 0, Num 0) 912 | , _circleRadius = Num 0 913 | } 914 | 915 | -- | Define an `` 916 | data Ellipse = Ellipse 917 | { -- | Drawing attributes of the ellipse. 918 | _ellipseDrawAttributes :: !DrawAttributes 919 | -- | Center of the ellipse, map to the `cx` 920 | -- and `cy` attributes. 921 | , _ellipseCenter :: !Point 922 | -- | Radius along the X axis, map the 923 | -- `rx` attribute. 924 | , _ellipseXRadius :: !Number 925 | -- | Radius along the Y axis, map the 926 | -- `ry` attribute. 927 | , _ellipseYRadius :: !Number 928 | } 929 | deriving (Eq, Show) 930 | 931 | -- makeClassy ''Ellipse 932 | -- | Lenses for the ellipse type. 933 | class HasEllipse c_amWt where 934 | ellipse :: Lens' c_amWt Ellipse 935 | ellipseCenter :: Lens' c_amWt Point 936 | {-# INLINE ellipseCenter #-} 937 | ellipseDrawAttributes :: Lens' c_amWt DrawAttributes 938 | {-# INLINE ellipseDrawAttributes #-} 939 | ellipseXRadius :: Lens' c_amWt Number 940 | {-# INLINE ellipseXRadius #-} 941 | ellipseYRadius :: Lens' c_amWt Number 942 | {-# INLINE ellipseYRadius #-} 943 | ellipseCenter = ((.) ellipse) ellipseCenter 944 | ellipseDrawAttributes = ((.) ellipse) ellipseDrawAttributes 945 | ellipseXRadius = ((.) ellipse) ellipseXRadius 946 | ellipseYRadius = ((.) ellipse) ellipseYRadius 947 | 948 | instance HasEllipse Ellipse where 949 | {-# INLINE ellipseCenter #-} 950 | {-# INLINE ellipseDrawAttributes #-} 951 | {-# INLINE ellipseXRadius #-} 952 | {-# INLINE ellipseYRadius #-} 953 | ellipse = id 954 | ellipseCenter f attr = 955 | fmap (\y -> attr { _ellipseCenter = y }) (f $ _ellipseCenter attr) 956 | ellipseDrawAttributes f attr = 957 | fmap (\y -> attr { _ellipseDrawAttributes = y }) (f $ _ellipseDrawAttributes attr) 958 | ellipseXRadius f attr = 959 | fmap (\y -> attr { _ellipseXRadius = y }) (f $ _ellipseXRadius attr) 960 | ellipseYRadius f attr = 961 | fmap (\y -> attr { _ellipseYRadius = y }) (f $ _ellipseYRadius attr) 962 | 963 | instance WithDrawAttributes Ellipse where 964 | drawAttr = ellipseDrawAttributes 965 | 966 | instance WithDefaultSvg Ellipse where 967 | defaultSvg = Ellipse 968 | { _ellipseDrawAttributes = mempty 969 | , _ellipseCenter = (Num 0, Num 0) 970 | , _ellipseXRadius = Num 0 971 | , _ellipseYRadius = Num 0 972 | } 973 | 974 | -- | Define a color stop for the gradients. Represent 975 | -- the `` SVG tag. 976 | data GradientStop = GradientStop 977 | { -- | Gradient offset between 0 and 1, correspond 978 | -- to the `offset` attribute. 979 | _gradientOffset :: !Float 980 | -- | Color of the gradient stop. Correspond 981 | -- to the `stop-color` attribute. 982 | , _gradientColor :: !PixelRGBA8 983 | -- | Path command used in mesh patch 984 | , _gradientPath :: !(Maybe GradientPathCommand) 985 | -- | Stop color opacity 986 | , _gradientOpacity :: !(Maybe Float) 987 | } 988 | deriving (Eq, Show) 989 | 990 | -- makeClassy ''GradientStop 991 | -- | Lenses for the GradientStop type. 992 | class HasGradientStop c_anhM where 993 | gradientStop :: Lens' c_anhM GradientStop 994 | gradientColor :: Lens' c_anhM PixelRGBA8 995 | {-# INLINE gradientColor #-} 996 | gradientOffset :: Lens' c_anhM Float 997 | {-# INLINE gradientOffset #-} 998 | gradientOpacity :: Lens' c_anhM (Maybe Float) 999 | {-# INLINE gradientOpacity #-} 1000 | gradientPath :: Lens' c_anhM (Maybe GradientPathCommand) 1001 | {-# INLINE gradientPath #-} 1002 | gradientColor = ((.) gradientStop) gradientColor 1003 | gradientOffset = ((.) gradientStop) gradientOffset 1004 | gradientOpacity = ((.) gradientStop) gradientOpacity 1005 | gradientPath = ((.) gradientStop) gradientPath 1006 | 1007 | instance HasGradientStop GradientStop where 1008 | {-# INLINE gradientColor #-} 1009 | {-# INLINE gradientOffset #-} 1010 | {-# INLINE gradientOpacity #-} 1011 | {-# INLINE gradientPath #-} 1012 | gradientStop = id 1013 | gradientColor f attr = 1014 | fmap (\y -> attr { _gradientColor = y }) (f $ _gradientColor attr) 1015 | gradientOffset f attr = 1016 | fmap (\y -> attr { _gradientOffset = y }) (f $ _gradientOffset attr) 1017 | gradientOpacity f attr = 1018 | fmap (\y -> attr { _gradientOpacity = y }) (f $ _gradientOpacity attr) 1019 | gradientPath f attr = 1020 | fmap (\y -> attr { _gradientPath = y }) (f $ _gradientPath attr) 1021 | 1022 | instance WithDefaultSvg GradientStop where 1023 | defaultSvg = GradientStop 1024 | { _gradientOffset = 0.0 1025 | , _gradientColor = PixelRGBA8 0 0 0 255 1026 | , _gradientPath = Nothing 1027 | , _gradientOpacity = Nothing 1028 | } 1029 | 1030 | 1031 | -- | Define `` SVG tag 1032 | data MeshGradientPatch = MeshGradientPatch 1033 | { -- | List of stop, from 2 to 4 in a patch 1034 | _meshGradientPatchStops :: ![GradientStop] 1035 | } 1036 | deriving (Eq, Show) 1037 | 1038 | -- makeClassy ''MeshGradientPatch 1039 | class HasMeshGradientPatch c_annx where 1040 | meshGradientPatch :: Lens' c_annx MeshGradientPatch 1041 | meshGradientPatchStops :: Lens' c_annx [GradientStop] 1042 | {-# INLINE meshGradientPatchStops #-} 1043 | meshGradientPatchStops = meshGradientPatch . meshGradientPatchStops 1044 | 1045 | instance HasMeshGradientPatch MeshGradientPatch where 1046 | {-# INLINE meshGradientPatchStops #-} 1047 | meshGradientPatch = id 1048 | meshGradientPatchStops f m = 1049 | fmap (\y -> m { _meshGradientPatchStops = y }) . f $ _meshGradientPatchStops m 1050 | 1051 | instance WithDefaultSvg MeshGradientPatch where 1052 | defaultSvg = MeshGradientPatch [] 1053 | 1054 | -- | Define a `` tag. 1055 | data MeshGradientRow = MeshGradientRow 1056 | { -- | List of patch in a row 1057 | _meshGradientRowPatches :: ![MeshGradientPatch] 1058 | } 1059 | deriving (Eq, Show) 1060 | 1061 | -- makeClassy ''MeshGradientRow 1062 | class HasMeshGradientRow c_antr where 1063 | meshGradientRow :: Lens' c_antr MeshGradientRow 1064 | meshGradientRowPatches :: Lens' c_antr [MeshGradientPatch] 1065 | {-# INLINE meshGradientRowPatches #-} 1066 | meshGradientRowPatches = meshGradientRow . meshGradientRowPatches 1067 | 1068 | instance HasMeshGradientRow MeshGradientRow where 1069 | {-# INLINE meshGradientRowPatches #-} 1070 | meshGradientRow = id 1071 | meshGradientRowPatches f m = 1072 | fmap (\y -> m { _meshGradientRowPatches = y }) . f $ _meshGradientRowPatches m 1073 | 1074 | instance WithDefaultSvg MeshGradientRow where 1075 | defaultSvg = MeshGradientRow [] 1076 | 1077 | 1078 | -- | Define a `` tag. 1079 | data MeshGradient = MeshGradient 1080 | { _meshGradientDrawAttributes :: !DrawAttributes 1081 | -- | Original x coordinate of the mesh gradient 1082 | , _meshGradientX :: !Number 1083 | -- | Original y coordinate of the mesh gradient 1084 | , _meshGradientY :: !Number 1085 | -- | Type of color interpolation to use 1086 | , _meshGradientType :: !MeshGradientType 1087 | -- | Coordiante system to use 1088 | , _meshGradientUnits :: !CoordinateUnits 1089 | -- | Optional transform 1090 | , _meshGradientTransform :: ![Transformation] 1091 | -- | List of patch rows in the the mesh. 1092 | , _meshGradientRows :: ![MeshGradientRow] 1093 | } 1094 | deriving (Eq, Show) 1095 | 1096 | -- makeClassy ''MeshGradient 1097 | class HasMeshGradient c_anxG where 1098 | meshGradient :: Lens' c_anxG MeshGradient 1099 | meshGradientDrawAttributes :: Lens' c_anxG DrawAttributes 1100 | {-# INLINE meshGradientDrawAttributes #-} 1101 | meshGradientRows :: Lens' c_anxG [MeshGradientRow] 1102 | {-# INLINE meshGradientRows #-} 1103 | meshGradientTransform :: Lens' c_anxG [Transformation] 1104 | {-# INLINE meshGradientTransform #-} 1105 | meshGradientType :: Lens' c_anxG MeshGradientType 1106 | {-# INLINE meshGradientType #-} 1107 | meshGradientUnits :: Lens' c_anxG CoordinateUnits 1108 | {-# INLINE meshGradientUnits #-} 1109 | meshGradientX :: Lens' c_anxG Number 1110 | {-# INLINE meshGradientX #-} 1111 | meshGradientY :: Lens' c_anxG Number 1112 | {-# INLINE meshGradientY #-} 1113 | meshGradientDrawAttributes 1114 | = ((.) meshGradient) meshGradientDrawAttributes 1115 | meshGradientRows = ((.) meshGradient) meshGradientRows 1116 | meshGradientTransform = ((.) meshGradient) meshGradientTransform 1117 | meshGradientType = ((.) meshGradient) meshGradientType 1118 | meshGradientUnits = ((.) meshGradient) meshGradientUnits 1119 | meshGradientX = ((.) meshGradient) meshGradientX 1120 | meshGradientY = ((.) meshGradient) meshGradientY 1121 | instance HasMeshGradient MeshGradient where 1122 | {-# INLINE meshGradientDrawAttributes #-} 1123 | {-# INLINE meshGradientRows #-} 1124 | {-# INLINE meshGradientTransform #-} 1125 | {-# INLINE meshGradientType #-} 1126 | {-# INLINE meshGradientUnits #-} 1127 | {-# INLINE meshGradientX #-} 1128 | {-# INLINE meshGradientY #-} 1129 | meshGradient = id 1130 | meshGradientDrawAttributes f attr = 1131 | fmap (\y -> attr { _meshGradientDrawAttributes = y }) (f $ _meshGradientDrawAttributes attr) 1132 | meshGradientRows f attr = 1133 | fmap (\y -> attr { _meshGradientRows = y }) (f $ _meshGradientRows attr) 1134 | meshGradientTransform f attr = 1135 | fmap (\y -> attr { _meshGradientTransform = y }) (f $ _meshGradientTransform attr) 1136 | meshGradientType f attr = 1137 | fmap (\y -> attr { _meshGradientType = y }) (f $ _meshGradientType attr) 1138 | meshGradientUnits f attr = 1139 | fmap (\y -> attr { _meshGradientUnits = y }) (f $ _meshGradientUnits attr) 1140 | meshGradientX f attr = 1141 | fmap (\y -> attr { _meshGradientX = y }) (f $ _meshGradientX attr) 1142 | meshGradientY f attr = 1143 | fmap (\y -> attr { _meshGradientY = y }) (f $ _meshGradientY attr) 1144 | 1145 | instance WithDrawAttributes MeshGradient where 1146 | drawAttr = meshGradientDrawAttributes 1147 | 1148 | instance WithDefaultSvg MeshGradient where 1149 | defaultSvg = MeshGradient 1150 | { _meshGradientDrawAttributes = mempty 1151 | , _meshGradientX = Percent 0 1152 | , _meshGradientY = Percent 0 1153 | , _meshGradientType = GradientBilinear 1154 | , _meshGradientUnits = CoordBoundingBox 1155 | , _meshGradientTransform = mempty 1156 | , _meshGradientRows = mempty 1157 | } 1158 | 1159 | 1160 | -- | Define an `` tag. 1161 | data Image = Image 1162 | { -- | Drawing attributes of the image 1163 | _imageDrawAttributes :: !DrawAttributes 1164 | -- | Position of the image referenced by its 1165 | -- upper left corner. 1166 | , _imageCornerUpperLeft :: !Point 1167 | -- | Image width 1168 | , _imageWidth :: !Number 1169 | -- | Image Height 1170 | , _imageHeight :: !Number 1171 | -- | Image href, pointing to the real image. 1172 | , _imageHref :: !String 1173 | -- | preserveAspectRatio attribute 1174 | , _imageAspectRatio :: !PreserveAspectRatio 1175 | } 1176 | deriving (Eq, Show) 1177 | 1178 | -- makeClassy ''Image 1179 | -- | Lenses for the Image type. 1180 | class HasImage c_anI7 where 1181 | image :: Lens' c_anI7 Image 1182 | imageAspectRatio :: Lens' c_anI7 PreserveAspectRatio 1183 | {-# INLINE imageAspectRatio #-} 1184 | imageCornerUpperLeft :: Lens' c_anI7 Point 1185 | {-# INLINE imageCornerUpperLeft #-} 1186 | imageDrawAttributes :: Lens' c_anI7 DrawAttributes 1187 | {-# INLINE imageDrawAttributes #-} 1188 | imageHeight :: Lens' c_anI7 Number 1189 | {-# INLINE imageHeight #-} 1190 | imageHref :: Lens' c_anI7 String 1191 | {-# INLINE imageHref #-} 1192 | imageWidth :: Lens' c_anI7 Number 1193 | {-# INLINE imageWidth #-} 1194 | imageAspectRatio = ((.) image) imageAspectRatio 1195 | imageCornerUpperLeft = ((.) image) imageCornerUpperLeft 1196 | imageDrawAttributes = ((.) image) imageDrawAttributes 1197 | imageHeight = ((.) image) imageHeight 1198 | imageHref = ((.) image) imageHref 1199 | imageWidth = ((.) image) imageWidth 1200 | instance HasImage Image where 1201 | {-# INLINE imageAspectRatio #-} 1202 | {-# INLINE imageCornerUpperLeft #-} 1203 | {-# INLINE imageDrawAttributes #-} 1204 | {-# INLINE imageHeight #-} 1205 | {-# INLINE imageHref #-} 1206 | {-# INLINE imageWidth #-} 1207 | image = id 1208 | imageAspectRatio f attr = 1209 | fmap (\y -> attr { _imageAspectRatio = y }) (f $ _imageAspectRatio attr) 1210 | imageCornerUpperLeft f attr = 1211 | fmap (\y -> attr { _imageCornerUpperLeft = y }) (f $ _imageCornerUpperLeft attr) 1212 | imageDrawAttributes f attr = 1213 | fmap (\y -> attr { _imageDrawAttributes = y }) (f $ _imageDrawAttributes attr) 1214 | imageHeight f attr = 1215 | fmap (\y -> attr { _imageHeight = y }) (f $ _imageHeight attr) 1216 | imageHref f attr = 1217 | fmap (\y -> attr { _imageHref = y }) (f $ _imageHref attr) 1218 | imageWidth f attr = 1219 | fmap (\y -> attr { _imageWidth = y }) (f $ _imageWidth attr) 1220 | 1221 | instance WithDrawAttributes Image where 1222 | drawAttr = imageDrawAttributes 1223 | 1224 | instance WithDefaultSvg Image where 1225 | defaultSvg = Image 1226 | { _imageDrawAttributes = mempty 1227 | , _imageCornerUpperLeft = (Num 0, Num 0) 1228 | , _imageWidth = Num 0 1229 | , _imageHeight = Num 0 1230 | , _imageHref = "" 1231 | , _imageAspectRatio = defaultSvg 1232 | } 1233 | 1234 | -- | Define an `` for a named content. 1235 | -- Every named content can be reused in the 1236 | -- document using this element. 1237 | data Use = Use 1238 | { -- | Position where to draw the "used" element. 1239 | -- Correspond to the `x` and `y` attributes. 1240 | _useBase :: Point 1241 | -- | Referenced name, correspond to `xlink:href` 1242 | -- attribute. 1243 | , _useName :: String 1244 | -- | Define the width of the region where 1245 | -- to place the element. Map to the `width` 1246 | -- attribute. 1247 | , _useWidth :: Maybe Number 1248 | -- | Define the height of the region where 1249 | -- to place the element. Map to the `height` 1250 | -- attribute. 1251 | , _useHeight :: Maybe Number 1252 | -- | Use draw attributes. 1253 | , _useDrawAttributes :: DrawAttributes 1254 | } 1255 | deriving (Eq, Show) 1256 | 1257 | -- makeClassy ''Use 1258 | -- | Lenses for the Use type. 1259 | class HasUse c_anR3 where 1260 | use :: Lens' c_anR3 Use 1261 | useBase :: Lens' c_anR3 Point 1262 | {-# INLINE useBase #-} 1263 | useDrawAttributes :: Lens' c_anR3 DrawAttributes 1264 | {-# INLINE useDrawAttributes #-} 1265 | useHeight :: Lens' c_anR3 (Maybe Number) 1266 | {-# INLINE useHeight #-} 1267 | useName :: Lens' c_anR3 String 1268 | {-# INLINE useName #-} 1269 | useWidth :: Lens' c_anR3 (Maybe Number) 1270 | {-# INLINE useWidth #-} 1271 | useBase = ((.) use) useBase 1272 | useDrawAttributes = ((.) use) useDrawAttributes 1273 | useHeight = ((.) use) useHeight 1274 | useName = ((.) use) useName 1275 | useWidth = ((.) use) useWidth 1276 | instance HasUse Use where 1277 | {-# INLINE useBase #-} 1278 | {-# INLINE useDrawAttributes #-} 1279 | {-# INLINE useHeight #-} 1280 | {-# INLINE useName #-} 1281 | {-# INLINE useWidth #-} 1282 | use = id 1283 | useBase f attr = 1284 | fmap (\y -> attr { _useBase = y }) (f $ _useBase attr) 1285 | useDrawAttributes f attr = 1286 | fmap (\y -> attr { _useDrawAttributes = y }) (f $ _useDrawAttributes attr) 1287 | useHeight f attr = 1288 | fmap (\y -> attr { _useHeight = y }) (f $ _useHeight attr) 1289 | useName f attr = 1290 | fmap (\y -> attr { _useName = y }) (f $ _useName attr) 1291 | useWidth f attr = 1292 | fmap (\y -> attr { _useWidth = y }) (f $ _useWidth attr) 1293 | 1294 | instance WithDrawAttributes Use where 1295 | drawAttr = useDrawAttributes 1296 | 1297 | instance WithDefaultSvg Use where 1298 | defaultSvg = Use 1299 | { _useBase = (Num 0, Num 0) 1300 | , _useName = "" 1301 | , _useWidth = Nothing 1302 | , _useHeight = Nothing 1303 | , _useDrawAttributes = mempty 1304 | } 1305 | 1306 | -- | Define position information associated to 1307 | -- `` or `` svg tag. 1308 | data TextInfo = TextInfo 1309 | { _textInfoX :: ![Number] -- ^ `x` attribute. 1310 | , _textInfoY :: ![Number] -- ^ `y` attribute. 1311 | , _textInfoDX :: ![Number] -- ^ `dx` attribute. 1312 | , _textInfoDY :: ![Number] -- ^ `dy` attribute. 1313 | , _textInfoRotate :: ![Double] -- ^ `rotate` attribute. 1314 | , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute. 1315 | } 1316 | deriving (Eq, Show) 1317 | 1318 | instance Semigroup TextInfo where 1319 | (<>) (TextInfo x1 y1 dx1 dy1 r1 l1) 1320 | (TextInfo x2 y2 dx2 dy2 r2 l2) = 1321 | TextInfo (x1 <> x2) (y1 <> y2) 1322 | (dx1 <> dx2) (dy1 <> dy2) 1323 | (r1 <> r2) 1324 | (getLast $ Last l1 <> Last l2) 1325 | 1326 | instance Monoid TextInfo where 1327 | mempty = TextInfo [] [] [] [] [] Nothing 1328 | mappend = (<>) 1329 | 1330 | -- makeClassy ''TextInfo 1331 | -- | Lenses for the TextInfo type. 1332 | class HasTextInfo c_ao0m where 1333 | textInfo :: Lens' c_ao0m TextInfo 1334 | textInfoDX :: Lens' c_ao0m [Number] 1335 | {-# INLINE textInfoDX #-} 1336 | textInfoDY :: Lens' c_ao0m [Number] 1337 | {-# INLINE textInfoDY #-} 1338 | textInfoLength :: Lens' c_ao0m (Maybe Number) 1339 | {-# INLINE textInfoLength #-} 1340 | textInfoRotate :: Lens' c_ao0m [Double] 1341 | {-# INLINE textInfoRotate #-} 1342 | textInfoX :: Lens' c_ao0m [Number] 1343 | {-# INLINE textInfoX #-} 1344 | textInfoY :: Lens' c_ao0m [Number] 1345 | {-# INLINE textInfoY #-} 1346 | textInfoDX = ((.) textInfo) textInfoDX 1347 | textInfoDY = ((.) textInfo) textInfoDY 1348 | textInfoLength = ((.) textInfo) textInfoLength 1349 | textInfoRotate = ((.) textInfo) textInfoRotate 1350 | textInfoX = ((.) textInfo) textInfoX 1351 | textInfoY = ((.) textInfo) textInfoY 1352 | instance HasTextInfo TextInfo where 1353 | {-# INLINE textInfoDX #-} 1354 | {-# INLINE textInfoDY #-} 1355 | {-# INLINE textInfoLength #-} 1356 | {-# INLINE textInfoRotate #-} 1357 | {-# INLINE textInfoX #-} 1358 | {-# INLINE textInfoY #-} 1359 | textInfo = id 1360 | textInfoDX f attr = 1361 | fmap (\y -> attr { _textInfoDX = y }) (f $ _textInfoDX attr) 1362 | textInfoDY f attr = 1363 | fmap (\y -> attr { _textInfoDY = y }) (f $ _textInfoDY attr) 1364 | textInfoLength f attr = 1365 | fmap (\y -> attr { _textInfoLength = y }) (f $ _textInfoLength attr) 1366 | textInfoRotate f attr = 1367 | fmap (\y -> attr { _textInfoRotate = y }) (f $ _textInfoRotate attr) 1368 | textInfoX f attr = 1369 | fmap (\y -> attr { _textInfoX = y }) (f $ _textInfoX attr) 1370 | textInfoY f attr = 1371 | fmap (\y -> attr { _textInfoY = y }) (f $ _textInfoY attr) 1372 | 1373 | instance WithDefaultSvg TextInfo where 1374 | defaultSvg = mempty 1375 | 1376 | -- | Define the content of a `` tag. 1377 | data TextSpanContent 1378 | = SpanText !T.Text -- ^ Raw text 1379 | | SpanTextRef !String -- ^ Equivalent to a `` 1380 | | SpanSub !TextSpan -- ^ Define a `` 1381 | deriving (Eq, Show) 1382 | 1383 | -- | Define a `` tag. 1384 | data TextSpan = TextSpan 1385 | { -- | Placing information for the text. 1386 | _spanInfo :: !TextInfo 1387 | -- | Drawing attributes for the text span. 1388 | , _spanDrawAttributes :: !DrawAttributes 1389 | -- | Content of the span. 1390 | , _spanContent :: ![TextSpanContent] 1391 | } 1392 | deriving (Eq, Show) 1393 | 1394 | -- makeClassy ''TextSpan 1395 | -- | Lenses for the TextSpan type. 1396 | class HasTextSpan c_aobD where 1397 | textSpan :: Lens' c_aobD TextSpan 1398 | spanContent :: Lens' c_aobD [TextSpanContent] 1399 | {-# INLINE spanContent #-} 1400 | spanDrawAttributes :: Lens' c_aobD DrawAttributes 1401 | {-# INLINE spanDrawAttributes #-} 1402 | spanInfo :: Lens' c_aobD TextInfo 1403 | {-# INLINE spanInfo #-} 1404 | spanContent = ((.) textSpan) spanContent 1405 | spanDrawAttributes = ((.) textSpan) spanDrawAttributes 1406 | spanInfo = ((.) textSpan) spanInfo 1407 | instance HasTextSpan TextSpan where 1408 | {-# INLINE spanContent #-} 1409 | {-# INLINE spanDrawAttributes #-} 1410 | {-# INLINE spanInfo #-} 1411 | textSpan = id 1412 | spanContent f attr = 1413 | fmap (\y -> attr { _spanContent = y }) (f $ _spanContent attr) 1414 | spanDrawAttributes f attr = 1415 | fmap (\y -> attr { _spanDrawAttributes = y }) (f $ _spanDrawAttributes attr) 1416 | spanInfo f attr = 1417 | fmap (\y -> attr { _spanInfo = y }) (f $ _spanInfo attr) 1418 | 1419 | instance WithDefaultSvg TextSpan where 1420 | defaultSvg = TextSpan 1421 | { _spanInfo = defaultSvg 1422 | , _spanDrawAttributes = mempty 1423 | , _spanContent = mempty 1424 | } 1425 | 1426 | -- | Describe the content of the `method` attribute on 1427 | -- text path. 1428 | data TextPathMethod 1429 | = TextPathAlign -- ^ Map to the `align` value. 1430 | | TextPathStretch -- ^ Map to the `stretch` value. 1431 | deriving (Eq, Show) 1432 | 1433 | -- | Describe the content of the `spacing` text path 1434 | -- attribute. 1435 | data TextPathSpacing 1436 | = TextPathSpacingExact -- ^ Map to the `exact` value. 1437 | | TextPathSpacingAuto -- ^ Map to the `auto` value. 1438 | deriving (Eq, Show) 1439 | 1440 | -- | Describe the `` SVG tag. 1441 | data TextPath = TextPath 1442 | { -- | Define the beginning offset on the path, 1443 | -- the `startOffset` attribute. 1444 | _textPathStartOffset :: !Number 1445 | -- | Define the `xlink:href` attribute. 1446 | , _textPathName :: !String 1447 | -- | Correspond to the `method` attribute. 1448 | , _textPathMethod :: !TextPathMethod 1449 | -- | Correspond to the `spacing` attribute. 1450 | , _textPathSpacing :: !TextPathSpacing 1451 | -- | Real content of the path. 1452 | , _textPathData :: ![PathCommand] 1453 | } 1454 | deriving (Eq, Show) 1455 | 1456 | -- makeClassy ''TextPath 1457 | -- | Lenses for the TextPath type. 1458 | class HasTextPath c_aojU where 1459 | textPath :: Lens' c_aojU TextPath 1460 | textPathData :: Lens' c_aojU [PathCommand] 1461 | {-# INLINE textPathData #-} 1462 | textPathMethod :: Lens' c_aojU TextPathMethod 1463 | {-# INLINE textPathMethod #-} 1464 | textPathName :: Lens' c_aojU String 1465 | {-# INLINE textPathName #-} 1466 | textPathSpacing :: Lens' c_aojU TextPathSpacing 1467 | {-# INLINE textPathSpacing #-} 1468 | textPathStartOffset :: Lens' c_aojU Number 1469 | {-# INLINE textPathStartOffset #-} 1470 | textPathData = ((.) textPath) textPathData 1471 | textPathMethod = ((.) textPath) textPathMethod 1472 | textPathName = ((.) textPath) textPathName 1473 | textPathSpacing = ((.) textPath) textPathSpacing 1474 | textPathStartOffset = ((.) textPath) textPathStartOffset 1475 | instance HasTextPath TextPath where 1476 | {-# INLINE textPathData #-} 1477 | {-# INLINE textPathMethod #-} 1478 | {-# INLINE textPathName #-} 1479 | {-# INLINE textPathSpacing #-} 1480 | {-# INLINE textPathStartOffset #-} 1481 | textPath = id 1482 | textPathData f attr = 1483 | fmap (\y -> attr { _textPathData = y }) (f $ _textPathData attr) 1484 | textPathMethod f attr = 1485 | fmap (\y -> attr { _textPathMethod = y }) (f $ _textPathMethod attr) 1486 | textPathName f attr = 1487 | fmap (\y -> attr { _textPathName = y }) (f $ _textPathName attr) 1488 | textPathSpacing f attr = 1489 | fmap (\y -> attr { _textPathSpacing = y }) (f $ _textPathSpacing attr) 1490 | textPathStartOffset f attr = 1491 | fmap (\y -> attr { _textPathStartOffset = y }) (f $ _textPathStartOffset attr) 1492 | 1493 | instance WithDefaultSvg TextPath where 1494 | defaultSvg = TextPath 1495 | { _textPathStartOffset = Num 0 1496 | , _textPathName = mempty 1497 | , _textPathMethod = TextPathAlign 1498 | , _textPathSpacing = TextPathSpacingExact 1499 | , _textPathData = [] 1500 | } 1501 | 1502 | -- | Define the possible values of the `lengthAdjust` 1503 | -- attribute. 1504 | data TextAdjust 1505 | = TextAdjustSpacing -- ^ Value `spacing` 1506 | | TextAdjustSpacingAndGlyphs -- ^ Value `spacingAndGlyphs` 1507 | deriving (Eq, Show) 1508 | 1509 | -- | Define the global `` SVG tag. 1510 | data Text = Text 1511 | { -- | Define the `lengthAdjust` attribute. 1512 | _textAdjust :: !TextAdjust 1513 | -- | Root of the text content. 1514 | , _textRoot :: !TextSpan 1515 | } 1516 | deriving (Eq, Show) 1517 | 1518 | -- makeClassy ''Text 1519 | -- | Lenses for the Text type. 1520 | class HasText c_aorD where 1521 | text :: Lens' c_aorD Text 1522 | textAdjust :: Lens' c_aorD TextAdjust 1523 | {-# INLINE textAdjust #-} 1524 | textRoot :: Lens' c_aorD TextSpan 1525 | {-# INLINE textRoot #-} 1526 | textAdjust = ((.) text) textAdjust 1527 | textRoot = ((.) text) textRoot 1528 | instance HasText Text where 1529 | {-# INLINE textAdjust #-} 1530 | {-# INLINE textRoot #-} 1531 | text = id 1532 | textAdjust f attr = 1533 | fmap (\y -> attr { _textAdjust = y }) (f $ _textAdjust attr) 1534 | textRoot f attr = 1535 | fmap (\y -> attr { _textRoot = y }) (f $ _textRoot attr) 1536 | 1537 | -- | Little helper to create a SVG text at a given 1538 | -- baseline position. 1539 | textAt :: Point -> T.Text -> Text 1540 | textAt (x, y) txt = Text TextAdjustSpacing tspan where 1541 | tspan = defaultSvg 1542 | { _spanContent = [SpanText txt] 1543 | , _spanInfo = defaultSvg 1544 | { _textInfoX = [x] 1545 | , _textInfoY = [y] 1546 | } 1547 | } 1548 | 1549 | instance WithDrawAttributes Text where 1550 | drawAttr = textRoot . spanDrawAttributes 1551 | 1552 | instance WithDefaultSvg Text where 1553 | defaultSvg = Text 1554 | { _textRoot = defaultSvg 1555 | , _textAdjust = TextAdjustSpacing 1556 | } 1557 | 1558 | -- | Main type for the scene description, reorient to 1559 | -- specific type describing each tag. 1560 | data Tree 1561 | = None 1562 | | UseTree { useInformation :: !Use 1563 | , useSubTree :: !(Maybe Tree) } 1564 | | GroupTree !(Group Tree) 1565 | | SymbolTree !(Symbol Tree) 1566 | | PathTree !Path 1567 | | CircleTree !Circle 1568 | | PolyLineTree !PolyLine 1569 | | PolygonTree !Polygon 1570 | | EllipseTree !Ellipse 1571 | | LineTree !Line 1572 | | RectangleTree !Rectangle 1573 | | TextTree !(Maybe TextPath) !Text 1574 | | ImageTree !Image 1575 | | MeshGradientTree !MeshGradient 1576 | deriving (Eq, Show) 1577 | 1578 | -- | Define the orientation, associated to the 1579 | -- `orient` attribute on the Marker 1580 | data MarkerOrientation 1581 | = OrientationAuto -- ^ Auto value 1582 | | OrientationAngle Coord -- ^ Specific angle. 1583 | deriving (Eq, Show) 1584 | 1585 | -- | Define the content of the `markerUnits` attribute 1586 | -- on the Marker. 1587 | data MarkerUnit 1588 | = MarkerUnitStrokeWidth -- ^ Value `strokeWidth` 1589 | | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse` 1590 | deriving (Eq, Show) 1591 | 1592 | -- | Define the content of the `markerUnits` attribute 1593 | -- on the Marker. 1594 | data Overflow 1595 | = OverflowVisible -- ^ Value `visible` 1596 | | OverflowHidden -- ^ Value `hidden` 1597 | deriving (Eq, Show) 1598 | 1599 | -- | Define the `` tag. 1600 | data Marker = Marker 1601 | { -- | Draw attributes of the marker. 1602 | _markerDrawAttributes :: DrawAttributes 1603 | -- | Define the reference point of the marker. 1604 | -- correspond to the `refX` and `refY` attributes. 1605 | , _markerRefPoint :: !(Number, Number) 1606 | -- | Define the width of the marker. Correspond to 1607 | -- the `markerWidth` attribute. 1608 | , _markerWidth :: !(Maybe Number) 1609 | -- | Define the height of the marker. Correspond to 1610 | -- the `markerHeight` attribute. 1611 | , _markerHeight :: !(Maybe Number) 1612 | -- | Correspond to the `orient` attribute. 1613 | , _markerOrient :: !(Maybe MarkerOrientation) 1614 | -- | Map the `markerUnits` attribute. 1615 | , _markerUnits :: !(Maybe MarkerUnit) 1616 | -- | Optional viewbox 1617 | , _markerViewBox :: !(Maybe (Double, Double, Double, Double)) 1618 | -- | Elements defining the marker. 1619 | , _markerOverflow :: !(Maybe Overflow) 1620 | -- | preserveAspectRatio attribute 1621 | , _markerAspectRatio :: !PreserveAspectRatio 1622 | -- | Elements defining the marker. 1623 | , _markerElements :: [Tree] 1624 | } 1625 | deriving (Eq, Show) 1626 | 1627 | -- makeClassy ''Marker 1628 | -- | Lenses for the Marker type. 1629 | class HasMarker c_aoKc where 1630 | marker :: Lens' c_aoKc Marker 1631 | markerAspectRatio :: Lens' c_aoKc PreserveAspectRatio 1632 | {-# INLINE markerAspectRatio #-} 1633 | markerDrawAttributes :: Lens' c_aoKc DrawAttributes 1634 | {-# INLINE markerDrawAttributes #-} 1635 | markerElements :: Lens' c_aoKc [Tree] 1636 | {-# INLINE markerElements #-} 1637 | markerHeight :: Lens' c_aoKc (Maybe Number) 1638 | {-# INLINE markerHeight #-} 1639 | markerOrient :: Lens' c_aoKc (Maybe MarkerOrientation) 1640 | {-# INLINE markerOrient #-} 1641 | markerOverflow :: Lens' c_aoKc (Maybe Overflow) 1642 | {-# INLINE markerOverflow #-} 1643 | markerRefPoint :: Lens' c_aoKc (Number, Number) 1644 | {-# INLINE markerRefPoint #-} 1645 | markerUnits :: Lens' c_aoKc (Maybe MarkerUnit) 1646 | {-# INLINE markerUnits #-} 1647 | markerViewBox :: 1648 | Lens' c_aoKc (Maybe (Double, Double, Double, Double)) 1649 | {-# INLINE markerViewBox #-} 1650 | markerWidth :: Lens' c_aoKc (Maybe Number) 1651 | {-# INLINE markerWidth #-} 1652 | markerAspectRatio = ((.) marker) markerAspectRatio 1653 | markerDrawAttributes = ((.) marker) markerDrawAttributes 1654 | markerElements = ((.) marker) markerElements 1655 | markerHeight = ((.) marker) markerHeight 1656 | markerOrient = ((.) marker) markerOrient 1657 | markerOverflow = ((.) marker) markerOverflow 1658 | markerRefPoint = ((.) marker) markerRefPoint 1659 | markerUnits = ((.) marker) markerUnits 1660 | markerViewBox = ((.) marker) markerViewBox 1661 | markerWidth = ((.) marker) markerWidth 1662 | instance HasMarker Marker where 1663 | {-# INLINE markerAspectRatio #-} 1664 | {-# INLINE markerDrawAttributes #-} 1665 | {-# INLINE markerElements #-} 1666 | {-# INLINE markerHeight #-} 1667 | {-# INLINE markerOrient #-} 1668 | {-# INLINE markerOverflow #-} 1669 | {-# INLINE markerRefPoint #-} 1670 | {-# INLINE markerUnits #-} 1671 | {-# INLINE markerViewBox #-} 1672 | {-# INLINE markerWidth #-} 1673 | marker = id 1674 | markerAspectRatio f attr = 1675 | fmap (\y -> attr { _markerAspectRatio = y }) (f $ _markerAspectRatio attr) 1676 | markerDrawAttributes f attr = 1677 | fmap (\y -> attr { _markerDrawAttributes = y }) (f $ _markerDrawAttributes attr) 1678 | markerElements f attr = 1679 | fmap (\y -> attr { _markerElements = y }) (f $ _markerElements attr) 1680 | markerHeight f attr = 1681 | fmap (\y -> attr { _markerHeight = y }) (f $ _markerHeight attr) 1682 | markerOrient f attr = 1683 | fmap (\y -> attr { _markerOrient = y }) (f $ _markerOrient attr) 1684 | markerOverflow f attr = 1685 | fmap (\y -> attr { _markerOverflow = y }) (f $ _markerOverflow attr) 1686 | markerRefPoint f attr = 1687 | fmap (\y -> attr { _markerRefPoint = y }) (f $ _markerRefPoint attr) 1688 | markerUnits f attr = 1689 | fmap (\y -> attr { _markerUnits = y }) (f $ _markerUnits attr) 1690 | markerViewBox f attr = 1691 | fmap (\y -> attr { _markerViewBox = y }) (f $ _markerViewBox attr) 1692 | markerWidth f attr = 1693 | fmap (\y -> attr { _markerWidth = y }) (f $ _markerWidth attr) 1694 | 1695 | instance WithDrawAttributes Marker where 1696 | drawAttr = markerDrawAttributes 1697 | 1698 | instance WithDefaultSvg Marker where 1699 | defaultSvg = Marker 1700 | { _markerDrawAttributes = mempty 1701 | , _markerRefPoint = (Num 0, Num 0) 1702 | , _markerWidth = Just (Num 3) 1703 | , _markerHeight = Just (Num 3) 1704 | , _markerOrient = Nothing -- MarkerOrientation 1705 | , _markerUnits = Nothing -- MarkerUnitStrokeWidth 1706 | , _markerViewBox = Nothing 1707 | , _markerOverflow = Nothing 1708 | , _markerElements = mempty 1709 | , _markerAspectRatio = defaultSvg 1710 | } 1711 | 1712 | -- | Insert element in the first sublist in the list of list. 1713 | appNode :: [[a]] -> a -> [[a]] 1714 | appNode [] e = [[e]] 1715 | appNode (curr:above) e = (e:curr) : above 1716 | 1717 | -- | Map a tree while propagating context information. 1718 | -- The function passed in parameter receive a list 1719 | -- representing the the path used to go arrive to the 1720 | -- current node. 1721 | zipTree :: ([[Tree]] -> Tree) -> Tree -> Tree 1722 | zipTree f = dig [] where 1723 | dig prev e@None = f $ appNode prev e 1724 | dig prev e@(UseTree _ Nothing) = f $ appNode prev e 1725 | dig prev e@(UseTree nfo (Just u)) = 1726 | f . appNode prev . UseTree nfo . Just $ dig ([] : appNode prev e) u 1727 | dig prev e@(GroupTree g) = 1728 | f . appNode prev . GroupTree $ zipGroup (appNode prev e) g 1729 | dig prev e@(SymbolTree g) = 1730 | f . appNode prev . SymbolTree . Symbol . 1731 | zipGroup (appNode prev e) $ _groupOfSymbol g 1732 | dig prev e@(PathTree _) = f $ appNode prev e 1733 | dig prev e@(CircleTree _) = f $ appNode prev e 1734 | dig prev e@(PolyLineTree _) = f $ appNode prev e 1735 | dig prev e@(PolygonTree _) = f $ appNode prev e 1736 | dig prev e@(EllipseTree _) = f $ appNode prev e 1737 | dig prev e@(LineTree _) = f $ appNode prev e 1738 | dig prev e@(RectangleTree _) = f $ appNode prev e 1739 | dig prev e@(TextTree _ _) = f $ appNode prev e 1740 | dig prev e@(ImageTree _) = f $ appNode prev e 1741 | dig prev e@(MeshGradientTree _) = f $ appNode prev e 1742 | 1743 | zipGroup prev g = g { _groupChildren = updatedChildren } 1744 | where 1745 | groupChild = _groupChildren g 1746 | updatedChildren = 1747 | [dig (c:prev) child 1748 | | (child, c) <- zip groupChild $ inits groupChild] 1749 | 1750 | -- | Fold all nodes of a SVG tree. 1751 | foldTree :: (a -> Tree -> a) -> a -> Tree -> a 1752 | foldTree f = go where 1753 | go acc e = case e of 1754 | None -> f acc e 1755 | UseTree _ _ -> f acc e 1756 | PathTree _ -> f acc e 1757 | CircleTree _ -> f acc e 1758 | PolyLineTree _ -> f acc e 1759 | PolygonTree _ -> f acc e 1760 | EllipseTree _ -> f acc e 1761 | LineTree _ -> f acc e 1762 | RectangleTree _ -> f acc e 1763 | TextTree _ _ -> f acc e 1764 | ImageTree _ -> f acc e 1765 | MeshGradientTree _ -> f acc e 1766 | GroupTree g -> 1767 | let subAcc = F.foldl' go acc $ _groupChildren g in 1768 | f subAcc e 1769 | SymbolTree s -> 1770 | let subAcc = 1771 | F.foldl' go acc . _groupChildren $ _groupOfSymbol s in 1772 | f subAcc e 1773 | 1774 | -- | Helper function mapping every tree element. 1775 | mapTree :: (Tree -> Tree) -> Tree -> Tree 1776 | mapTree f = go where 1777 | go e@None = f e 1778 | go e@(UseTree _ _) = f e 1779 | go (GroupTree g) = f . GroupTree $ mapGroup g 1780 | go (SymbolTree g) = 1781 | f . SymbolTree . Symbol . mapGroup $ _groupOfSymbol g 1782 | go e@(PathTree _) = f e 1783 | go e@(CircleTree _) = f e 1784 | go e@(PolyLineTree _) = f e 1785 | go e@(PolygonTree _) = f e 1786 | go e@(EllipseTree _) = f e 1787 | go e@(LineTree _) = f e 1788 | go e@(RectangleTree _) = f e 1789 | go e@(TextTree _ _) = f e 1790 | go e@(ImageTree _) = f e 1791 | go e@(MeshGradientTree _) = f e 1792 | 1793 | mapGroup g = 1794 | g { _groupChildren = map go $ _groupChildren g } 1795 | 1796 | -- | For every element of a svg tree, associate 1797 | -- it's SVG tag name. 1798 | nameOfTree :: Tree -> T.Text 1799 | nameOfTree v = 1800 | case v of 1801 | None -> "" 1802 | UseTree _ _ -> "use" 1803 | GroupTree _ -> "g" 1804 | SymbolTree _ -> "symbol" 1805 | PathTree _ -> "path" 1806 | CircleTree _ -> "circle" 1807 | PolyLineTree _ -> "polyline" 1808 | PolygonTree _ -> "polygon" 1809 | EllipseTree _ -> "ellipse" 1810 | LineTree _ -> "line" 1811 | RectangleTree _ -> "rectangle" 1812 | TextTree _ _ -> "text" 1813 | ImageTree _ -> "image" 1814 | MeshGradientTree _ -> "meshgradient" 1815 | 1816 | drawAttrOfTree :: Tree -> DrawAttributes 1817 | drawAttrOfTree v = case v of 1818 | None -> mempty 1819 | UseTree e _ -> e ^. drawAttr 1820 | GroupTree e -> e ^. drawAttr 1821 | SymbolTree e -> e ^. drawAttr 1822 | PathTree e -> e ^. drawAttr 1823 | CircleTree e -> e ^. drawAttr 1824 | PolyLineTree e -> e ^. drawAttr 1825 | PolygonTree e -> e ^. drawAttr 1826 | EllipseTree e -> e ^. drawAttr 1827 | LineTree e -> e ^. drawAttr 1828 | RectangleTree e -> e ^. drawAttr 1829 | TextTree _ e -> e ^. drawAttr 1830 | ImageTree e -> e ^. drawAttr 1831 | MeshGradientTree e -> e ^. drawAttr 1832 | 1833 | setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree 1834 | setDrawAttrOfTree v attr = case v of 1835 | None -> None 1836 | UseTree e m -> UseTree (e & drawAttr .~ attr) m 1837 | GroupTree e -> GroupTree $ e & drawAttr .~ attr 1838 | SymbolTree e -> SymbolTree $ e & drawAttr .~ attr 1839 | PathTree e -> PathTree $ e & drawAttr .~ attr 1840 | CircleTree e -> CircleTree $ e & drawAttr .~ attr 1841 | PolyLineTree e -> PolyLineTree $ e & drawAttr .~ attr 1842 | PolygonTree e -> PolygonTree $ e & drawAttr .~ attr 1843 | EllipseTree e -> EllipseTree $ e & drawAttr .~ attr 1844 | LineTree e -> LineTree $ e & drawAttr .~ attr 1845 | RectangleTree e -> RectangleTree $ e & drawAttr .~ attr 1846 | TextTree a e -> TextTree a $ e & drawAttr .~ attr 1847 | ImageTree e -> ImageTree $ e & drawAttr .~ attr 1848 | MeshGradientTree e -> MeshGradientTree $ e & drawAttr .~ attr 1849 | 1850 | instance WithDrawAttributes Tree where 1851 | drawAttr = lens drawAttrOfTree setDrawAttrOfTree 1852 | 1853 | instance WithDefaultSvg Tree where 1854 | defaultSvg = None 1855 | 1856 | -- | Define the possible values for the `spreadMethod` 1857 | -- values used for the gradient definitions. 1858 | data Spread 1859 | = SpreadRepeat -- ^ `reapeat` value 1860 | | SpreadPad -- ^ `pad` value 1861 | | SpreadReflect -- ^ `reflect value` 1862 | deriving (Eq, Show) 1863 | 1864 | -- | Define a `` tag. 1865 | data LinearGradient = LinearGradient 1866 | { -- | Define coordinate system of the gradient, 1867 | -- associated to the `gradientUnits` attribute. 1868 | _linearGradientUnits :: CoordinateUnits 1869 | -- | Point defining the beginning of the line gradient. 1870 | -- Associated to the `x1` and `y1` attribute. 1871 | , _linearGradientStart :: Point 1872 | -- | Point defining the end of the line gradient. 1873 | -- Associated to the `x2` and `y2` attribute. 1874 | , _linearGradientStop :: Point 1875 | -- | Define how to handle the values outside 1876 | -- the gradient start and stop. Associated to the 1877 | -- `spreadMethod` attribute. 1878 | , _linearGradientSpread :: Spread 1879 | -- | Define the transformation to apply to the 1880 | -- gradient points. Associated to the `gradientTransform` 1881 | -- attribute. 1882 | , _linearGradientTransform :: [Transformation] 1883 | -- | List of color stops of the linear gradient. 1884 | , _linearGradientStops :: [GradientStop] 1885 | } 1886 | deriving (Eq, Show) 1887 | 1888 | -- makeClassy ''LinearGradient 1889 | -- | Lenses for the LinearGradient type. 1890 | class HasLinearGradient c_apmJ where 1891 | linearGradient :: Lens' c_apmJ LinearGradient 1892 | linearGradientSpread :: Lens' c_apmJ Spread 1893 | {-# INLINE linearGradientSpread #-} 1894 | linearGradientStart :: Lens' c_apmJ Point 1895 | {-# INLINE linearGradientStart #-} 1896 | linearGradientStop :: Lens' c_apmJ Point 1897 | {-# INLINE linearGradientStop #-} 1898 | linearGradientStops :: Lens' c_apmJ [GradientStop] 1899 | {-# INLINE linearGradientStops #-} 1900 | linearGradientTransform :: Lens' c_apmJ [Transformation] 1901 | {-# INLINE linearGradientTransform #-} 1902 | linearGradientUnits :: Lens' c_apmJ CoordinateUnits 1903 | {-# INLINE linearGradientUnits #-} 1904 | linearGradientSpread = ((.) linearGradient) linearGradientSpread 1905 | linearGradientStart = ((.) linearGradient) linearGradientStart 1906 | linearGradientStop = ((.) linearGradient) linearGradientStop 1907 | linearGradientStops = ((.) linearGradient) linearGradientStops 1908 | linearGradientTransform 1909 | = ((.) linearGradient) linearGradientTransform 1910 | linearGradientUnits = ((.) linearGradient) linearGradientUnits 1911 | 1912 | instance HasLinearGradient LinearGradient where 1913 | {-# INLINE linearGradientSpread #-} 1914 | {-# INLINE linearGradientStart #-} 1915 | {-# INLINE linearGradientStop #-} 1916 | {-# INLINE linearGradientStops #-} 1917 | {-# INLINE linearGradientTransform #-} 1918 | {-# INLINE linearGradientUnits #-} 1919 | linearGradient = id 1920 | linearGradientSpread f attr = 1921 | fmap (\y -> attr { _linearGradientSpread = y }) (f $ _linearGradientSpread attr) 1922 | linearGradientStart f attr = 1923 | fmap (\y -> attr { _linearGradientStart = y }) (f $ _linearGradientStart attr) 1924 | linearGradientStop f attr = 1925 | fmap (\y -> attr { _linearGradientStop = y }) (f $ _linearGradientStop attr) 1926 | linearGradientStops f attr = 1927 | fmap (\y -> attr { _linearGradientStops = y }) (f $ _linearGradientStops attr) 1928 | linearGradientTransform f attr = 1929 | fmap (\y -> attr { _linearGradientTransform = y }) (f $ _linearGradientTransform attr) 1930 | linearGradientUnits f attr = 1931 | fmap (\y -> attr { _linearGradientUnits = y }) (f $ _linearGradientUnits attr) 1932 | 1933 | instance WithDefaultSvg LinearGradient where 1934 | defaultSvg = LinearGradient 1935 | { _linearGradientUnits = CoordBoundingBox 1936 | , _linearGradientStart = (Percent 0, Percent 0) 1937 | , _linearGradientStop = (Percent 1, Percent 0) 1938 | , _linearGradientSpread = SpreadPad 1939 | , _linearGradientTransform = [] 1940 | , _linearGradientStops = [] 1941 | } 1942 | 1943 | -- | Define a `` tag. 1944 | data RadialGradient = RadialGradient 1945 | { -- | Define coordinate system of the gradient, 1946 | -- associated to the `gradientUnits` attribute. 1947 | _radialGradientUnits :: CoordinateUnits 1948 | -- | Center of the radial gradient. Associated to 1949 | -- the `cx` and `cy` attributes. 1950 | , _radialGradientCenter :: Point 1951 | -- | Radius of the radial gradient. Associated to 1952 | -- the `r` attribute. 1953 | , _radialGradientRadius :: Number 1954 | -- | X coordinate of the focus point of the radial 1955 | -- gradient. Associated to the `fx` attribute. 1956 | , _radialGradientFocusX :: Maybe Number 1957 | -- | Y coordinate of the focus point of the radial 1958 | -- gradient. Associated to the `fy` attribute. 1959 | , _radialGradientFocusY :: Maybe Number 1960 | -- | Define how to handle the values outside 1961 | -- the gradient start and stop. Associated to the 1962 | -- `spreadMethod` attribute. 1963 | , _radialGradientSpread :: Spread 1964 | -- | Define the transformation to apply to the 1965 | -- gradient points. Associated to the `gradientTransform` 1966 | -- attribute. 1967 | , _radialGradientTransform :: [Transformation] 1968 | -- | List of color stops of the radial gradient. 1969 | , _radialGradientStops :: [GradientStop] 1970 | } 1971 | deriving (Eq, Show) 1972 | 1973 | -- makeClassy ''RadialGradient 1974 | -- | Lenses for the RadialGradient type. 1975 | 1976 | class HasRadialGradient c_apwt where 1977 | radialGradient :: Lens' c_apwt RadialGradient 1978 | radialGradientCenter :: Lens' c_apwt Point 1979 | {-# INLINE radialGradientCenter #-} 1980 | radialGradientFocusX :: Lens' c_apwt (Maybe Number) 1981 | {-# INLINE radialGradientFocusX #-} 1982 | radialGradientFocusY :: Lens' c_apwt (Maybe Number) 1983 | {-# INLINE radialGradientFocusY #-} 1984 | radialGradientRadius :: Lens' c_apwt Number 1985 | {-# INLINE radialGradientRadius #-} 1986 | radialGradientSpread :: Lens' c_apwt Spread 1987 | {-# INLINE radialGradientSpread #-} 1988 | radialGradientStops :: Lens' c_apwt [GradientStop] 1989 | {-# INLINE radialGradientStops #-} 1990 | radialGradientTransform :: Lens' c_apwt [Transformation] 1991 | {-# INLINE radialGradientTransform #-} 1992 | radialGradientUnits :: Lens' c_apwt CoordinateUnits 1993 | {-# INLINE radialGradientUnits #-} 1994 | radialGradientCenter = ((.) radialGradient) radialGradientCenter 1995 | radialGradientFocusX = ((.) radialGradient) radialGradientFocusX 1996 | radialGradientFocusY = ((.) radialGradient) radialGradientFocusY 1997 | radialGradientRadius = ((.) radialGradient) radialGradientRadius 1998 | radialGradientSpread = ((.) radialGradient) radialGradientSpread 1999 | radialGradientStops = ((.) radialGradient) radialGradientStops 2000 | radialGradientTransform 2001 | = ((.) radialGradient) radialGradientTransform 2002 | radialGradientUnits = ((.) radialGradient) radialGradientUnits 2003 | 2004 | instance HasRadialGradient RadialGradient where 2005 | {-# INLINE radialGradientCenter #-} 2006 | {-# INLINE radialGradientFocusX #-} 2007 | {-# INLINE radialGradientFocusY #-} 2008 | {-# INLINE radialGradientRadius #-} 2009 | {-# INLINE radialGradientSpread #-} 2010 | {-# INLINE radialGradientStops #-} 2011 | {-# INLINE radialGradientTransform #-} 2012 | {-# INLINE radialGradientUnits #-} 2013 | radialGradient = id 2014 | radialGradientCenter f attr = 2015 | fmap (\y -> attr { _radialGradientCenter = y }) (f $ _radialGradientCenter attr) 2016 | radialGradientFocusX f attr = 2017 | fmap (\y -> attr { _radialGradientFocusX = y }) (f $ _radialGradientFocusX attr) 2018 | radialGradientFocusY f attr = 2019 | fmap (\y -> attr { _radialGradientFocusY = y }) (f $ _radialGradientFocusY attr) 2020 | radialGradientRadius f attr = 2021 | fmap (\y -> attr { _radialGradientRadius = y }) (f $ _radialGradientRadius attr) 2022 | radialGradientSpread f attr = 2023 | fmap (\y -> attr { _radialGradientSpread = y }) (f $ _radialGradientSpread attr) 2024 | radialGradientStops f attr = 2025 | fmap (\y -> attr { _radialGradientStops = y }) (f $ _radialGradientStops attr) 2026 | radialGradientTransform f attr = 2027 | fmap (\y -> attr { _radialGradientTransform = y }) (f $ _radialGradientTransform attr) 2028 | radialGradientUnits f attr = 2029 | fmap (\y -> attr { _radialGradientUnits = y }) (f $ _radialGradientUnits attr) 2030 | 2031 | instance WithDefaultSvg RadialGradient where 2032 | defaultSvg = RadialGradient 2033 | { _radialGradientUnits = CoordBoundingBox 2034 | , _radialGradientCenter = (Percent 0.5, Percent 0.5) 2035 | , _radialGradientRadius = Percent 0.5 2036 | , _radialGradientFocusX = Nothing 2037 | , _radialGradientFocusY = Nothing 2038 | , _radialGradientSpread = SpreadPad 2039 | , _radialGradientTransform = [] 2040 | , _radialGradientStops = [] 2041 | } 2042 | 2043 | -- | Define a SVG `` tag. 2044 | data Mask = Mask 2045 | { -- | Drawing attributes of the Mask 2046 | _maskDrawAttributes :: DrawAttributes 2047 | -- | Correspond to the `maskContentUnits` attributes. 2048 | , _maskContentUnits :: CoordinateUnits 2049 | -- | Mapping to the `maskUnits` attribute. 2050 | , _maskUnits :: CoordinateUnits 2051 | -- | Map to the `x` and `y` attributes. 2052 | , _maskPosition :: Point 2053 | -- | Map to the `width` attribute 2054 | , _maskWidth :: Number 2055 | -- | Map to the `height` attribute. 2056 | , _maskHeight :: Number 2057 | -- | Children of the `` tag. 2058 | , _maskContent :: [Tree] 2059 | } 2060 | deriving (Eq, Show) 2061 | 2062 | -- makeClassy ''Mask 2063 | -- | Lenses for the Mask type. 2064 | class HasMask c_apHI where 2065 | mask :: Lens' c_apHI Mask 2066 | maskContent :: Lens' c_apHI [Tree] 2067 | {-# INLINE maskContent #-} 2068 | maskContentUnits :: Lens' c_apHI CoordinateUnits 2069 | {-# INLINE maskContentUnits #-} 2070 | maskDrawAttributes :: Lens' c_apHI DrawAttributes 2071 | {-# INLINE maskDrawAttributes #-} 2072 | maskHeight :: Lens' c_apHI Number 2073 | {-# INLINE maskHeight #-} 2074 | maskPosition :: Lens' c_apHI Point 2075 | {-# INLINE maskPosition #-} 2076 | maskUnits :: Lens' c_apHI CoordinateUnits 2077 | {-# INLINE maskUnits #-} 2078 | maskWidth :: Lens' c_apHI Number 2079 | {-# INLINE maskWidth #-} 2080 | maskContent = ((.) mask) maskContent 2081 | maskContentUnits = ((.) mask) maskContentUnits 2082 | maskDrawAttributes = ((.) mask) maskDrawAttributes 2083 | maskHeight = ((.) mask) maskHeight 2084 | maskPosition = ((.) mask) maskPosition 2085 | maskUnits = ((.) mask) maskUnits 2086 | maskWidth = ((.) mask) maskWidth 2087 | 2088 | instance HasMask Mask where 2089 | {-# INLINE maskContent #-} 2090 | {-# INLINE maskContentUnits #-} 2091 | {-# INLINE maskDrawAttributes #-} 2092 | {-# INLINE maskHeight #-} 2093 | {-# INLINE maskPosition #-} 2094 | {-# INLINE maskUnits #-} 2095 | {-# INLINE maskWidth #-} 2096 | mask = id 2097 | maskContent f attr = 2098 | fmap (\y -> attr { _maskContent = y }) (f $ _maskContent attr) 2099 | maskContentUnits f attr = 2100 | fmap (\y -> attr { _maskContentUnits = y }) (f $ _maskContentUnits attr) 2101 | maskDrawAttributes f attr = 2102 | fmap (\y -> attr { _maskDrawAttributes = y }) (f $ _maskDrawAttributes attr) 2103 | maskHeight f attr = 2104 | fmap (\y -> attr { _maskHeight = y }) (f $ _maskHeight attr) 2105 | maskPosition f attr = 2106 | fmap (\y -> attr { _maskPosition = y }) (f $ _maskPosition attr) 2107 | maskUnits f attr = 2108 | fmap (\y -> attr { _maskUnits = y }) (f $ _maskUnits attr) 2109 | maskWidth f attr = 2110 | fmap (\y -> attr { _maskWidth = y }) (f $ _maskWidth attr) 2111 | 2112 | instance WithDrawAttributes Mask where 2113 | drawAttr = maskDrawAttributes 2114 | 2115 | instance WithDefaultSvg Mask where 2116 | defaultSvg = Mask 2117 | { _maskDrawAttributes = mempty 2118 | , _maskContentUnits = CoordUserSpace 2119 | , _maskUnits = CoordBoundingBox 2120 | , _maskPosition = (Percent (-0.1), Percent (-0.1)) 2121 | , _maskWidth = Percent 1.2 2122 | , _maskHeight = Percent 1.2 2123 | , _maskContent = [] 2124 | } 2125 | 2126 | -- | Define a `` tag. 2127 | data ClipPath = ClipPath 2128 | { _clipPathDrawAttributes :: DrawAttributes 2129 | -- | Maps to the `clipPathUnits` attribute 2130 | , _clipPathUnits :: CoordinateUnits 2131 | -- | Maps to the content of the tree 2132 | , _clipPathContent :: [Tree] 2133 | } 2134 | deriving (Eq, Show) 2135 | 2136 | -- makeClassy ''ClipPath 2137 | -- | Lenses for the ClipPath type. 2138 | class HasClipPath c_apZq where 2139 | clipPath :: Lens' c_apZq ClipPath 2140 | clipPathContent :: Lens' c_apZq [Tree] 2141 | {-# INLINE clipPathContent #-} 2142 | clipPathDrawAttributes :: Lens' c_apZq DrawAttributes 2143 | {-# INLINE clipPathDrawAttributes #-} 2144 | clipPathUnits :: Lens' c_apZq CoordinateUnits 2145 | {-# INLINE clipPathUnits #-} 2146 | clipPathContent = ((.) clipPath) clipPathContent 2147 | clipPathDrawAttributes = ((.) clipPath) clipPathDrawAttributes 2148 | clipPathUnits = ((.) clipPath) clipPathUnits 2149 | instance HasClipPath ClipPath where 2150 | {-# INLINE clipPathContent #-} 2151 | {-# INLINE clipPathDrawAttributes #-} 2152 | {-# INLINE clipPathUnits #-} 2153 | clipPath = id 2154 | clipPathContent f attr = 2155 | fmap (\y -> attr { _clipPathContent = y }) (f $ _clipPathContent attr) 2156 | clipPathDrawAttributes f attr = 2157 | fmap (\y -> attr { _clipPathDrawAttributes = y }) (f $ _clipPathDrawAttributes attr) 2158 | clipPathUnits f attr = 2159 | fmap (\y -> attr { _clipPathUnits = y }) (f $ _clipPathUnits attr) 2160 | 2161 | instance WithDrawAttributes ClipPath where 2162 | drawAttr = clipPathDrawAttributes 2163 | 2164 | instance WithDefaultSvg ClipPath where 2165 | defaultSvg = ClipPath 2166 | { _clipPathDrawAttributes = mempty 2167 | , _clipPathUnits = CoordUserSpace 2168 | , _clipPathContent = mempty 2169 | } 2170 | 2171 | -- | Define a `` tag. 2172 | data Pattern = Pattern 2173 | { -- | Pattern drawing attributes. 2174 | _patternDrawAttributes :: !DrawAttributes 2175 | -- | Possible `viewBox`. 2176 | , _patternViewBox :: !(Maybe (Double, Double, Double, Double)) 2177 | -- | Width of the pattern tile, mapped to the 2178 | -- `width` attribute 2179 | , _patternWidth :: !Number 2180 | -- | Height of the pattern tile, mapped to the 2181 | -- `height` attribute 2182 | , _patternHeight :: !Number 2183 | -- | Pattern tile base, mapped to the `x` and 2184 | -- `y` attributes. 2185 | , _patternPos :: !Point 2186 | -- | Patterns can be chained, so this is a potential 2187 | -- reference to another pattern 2188 | , _patternHref :: !String 2189 | -- | Elements used in the pattern. 2190 | , _patternElements :: ![Tree] 2191 | -- | Define the cordinate system to use for 2192 | -- the pattern. Mapped to the `patternUnits` 2193 | -- attribute. 2194 | , _patternUnit :: !CoordinateUnits 2195 | -- | Value of the "preserveAspectRatio" attribute 2196 | , _patternAspectRatio :: !PreserveAspectRatio 2197 | -- | Value of "patternTransform" attribute 2198 | , _patternTransform :: !(Maybe [Transformation]) 2199 | } 2200 | deriving Show 2201 | 2202 | -- makeClassy ''Pattern 2203 | -- | Lenses for the Patter type. 2204 | class HasPattern c_aq6G where 2205 | pattern :: Lens' c_aq6G Pattern 2206 | patternAspectRatio :: Lens' c_aq6G PreserveAspectRatio 2207 | {-# INLINE patternAspectRatio #-} 2208 | patternDrawAttributes :: Lens' c_aq6G DrawAttributes 2209 | {-# INLINE patternDrawAttributes #-} 2210 | patternElements :: Lens' c_aq6G [Tree] 2211 | {-# INLINE patternElements #-} 2212 | patternHeight :: Lens' c_aq6G Number 2213 | {-# INLINE patternHeight #-} 2214 | patternHref :: Lens' c_aq6G String 2215 | {-# INLINE patternHref #-} 2216 | patternPos :: Lens' c_aq6G Point 2217 | {-# INLINE patternPos #-} 2218 | patternTransform :: Lens' c_aq6G (Maybe [Transformation]) 2219 | {-# INLINE patternTransform #-} 2220 | patternUnit :: Lens' c_aq6G CoordinateUnits 2221 | {-# INLINE patternUnit #-} 2222 | patternViewBox :: 2223 | Lens' c_aq6G (Maybe (Double, Double, Double, Double)) 2224 | {-# INLINE patternViewBox #-} 2225 | patternWidth :: Lens' c_aq6G Number 2226 | {-# INLINE patternWidth #-} 2227 | patternAspectRatio = ((.) pattern) patternAspectRatio 2228 | patternDrawAttributes = ((.) pattern) patternDrawAttributes 2229 | patternElements = ((.) pattern) patternElements 2230 | patternHeight = ((.) pattern) patternHeight 2231 | patternHref = ((.) pattern) patternHref 2232 | patternPos = ((.) pattern) patternPos 2233 | patternTransform = ((.) pattern) patternTransform 2234 | patternUnit = ((.) pattern) patternUnit 2235 | patternViewBox = ((.) pattern) patternViewBox 2236 | patternWidth = ((.) pattern) patternWidth 2237 | 2238 | instance HasPattern Pattern where 2239 | {-# INLINE patternAspectRatio #-} 2240 | {-# INLINE patternDrawAttributes #-} 2241 | {-# INLINE patternElements #-} 2242 | {-# INLINE patternHeight #-} 2243 | {-# INLINE patternHref #-} 2244 | {-# INLINE patternPos #-} 2245 | {-# INLINE patternTransform #-} 2246 | {-# INLINE patternUnit #-} 2247 | {-# INLINE patternViewBox #-} 2248 | {-# INLINE patternWidth #-} 2249 | pattern = id 2250 | patternAspectRatio f attr = 2251 | fmap (\y -> attr { _patternAspectRatio = y }) (f $ _patternAspectRatio attr) 2252 | patternDrawAttributes f attr = 2253 | fmap (\y -> attr { _patternDrawAttributes = y }) (f $ _patternDrawAttributes attr) 2254 | patternElements f attr = 2255 | fmap (\y -> attr { _patternElements = y }) (f $ _patternElements attr) 2256 | patternHeight f attr = 2257 | fmap (\y -> attr { _patternHeight = y }) (f $ _patternHeight attr) 2258 | patternHref f attr = 2259 | fmap (\y -> attr { _patternHref = y }) (f $ _patternHref attr) 2260 | patternPos f attr = 2261 | fmap (\y -> attr { _patternPos = y }) (f $ _patternPos attr) 2262 | patternTransform f attr = 2263 | fmap (\y -> attr { _patternTransform = y }) (f $ _patternTransform attr) 2264 | patternUnit f attr = 2265 | fmap (\y -> attr { _patternUnit = y }) (f $ _patternUnit attr) 2266 | patternViewBox f attr = 2267 | fmap (\y -> attr { _patternViewBox = y }) (f $ _patternViewBox attr) 2268 | patternWidth f attr = 2269 | fmap (\y -> attr { _patternWidth = y }) (f $ _patternWidth attr) 2270 | 2271 | instance WithDrawAttributes Pattern where 2272 | drawAttr = patternDrawAttributes 2273 | 2274 | instance WithDefaultSvg Pattern where 2275 | defaultSvg = Pattern 2276 | { _patternViewBox = Nothing 2277 | , _patternWidth = Num 0 2278 | , _patternHeight = Num 0 2279 | , _patternPos = (Num 0, Num 0) 2280 | , _patternElements = [] 2281 | , _patternUnit = CoordBoundingBox 2282 | , _patternDrawAttributes = mempty 2283 | , _patternAspectRatio = defaultSvg 2284 | , _patternHref = "" 2285 | , _patternTransform = mempty 2286 | } 2287 | 2288 | -- | Sum types helping keeping track of all the namable 2289 | -- elemens in a SVG document. 2290 | data Element 2291 | = ElementLinearGradient LinearGradient 2292 | | ElementRadialGradient RadialGradient 2293 | | ElementMeshGradient MeshGradient 2294 | | ElementGeometry Tree 2295 | | ElementPattern Pattern 2296 | | ElementMarker Marker 2297 | | ElementMask Mask 2298 | | ElementClipPath ClipPath 2299 | deriving Show 2300 | 2301 | -- | Represent a full svg document with style, 2302 | -- geometry and named elements. 2303 | data Document = Document 2304 | { _viewBox :: Maybe (Double, Double, Double, Double) 2305 | , _width :: Maybe Number 2306 | , _height :: Maybe Number 2307 | , _elements :: [Tree] 2308 | , _definitions :: M.Map String Element 2309 | , _description :: String 2310 | , _styleRules :: [CssRule] 2311 | , _documentLocation :: FilePath 2312 | } 2313 | deriving Show 2314 | 2315 | -- makeClassy ''Document 2316 | -- | Lenses associated to a SVG document. 2317 | class HasDocument c_aqpq where 2318 | document :: Lens' c_aqpq Document 2319 | definitions :: Lens' c_aqpq (M.Map String Element) 2320 | {-# INLINE definitions #-} 2321 | definitions = document . definitions 2322 | 2323 | description :: Lens' c_aqpq String 2324 | {-# INLINE description #-} 2325 | description = document . description 2326 | 2327 | documentLocation :: Lens' c_aqpq FilePath 2328 | {-# INLINE documentLocation #-} 2329 | documentLocation = document . documentLocation 2330 | 2331 | elements :: Lens' c_aqpq [Tree] 2332 | {-# INLINE elements #-} 2333 | elements = document . elements 2334 | 2335 | height :: Lens' c_aqpq (Maybe Number) 2336 | {-# INLINE height #-} 2337 | height = document . height 2338 | 2339 | styleRules :: Lens' c_aqpq [CssRule] 2340 | {-# INLINE styleRules #-} 2341 | styleRules = document . styleRules 2342 | 2343 | viewBox :: Lens' c_aqpq (Maybe (Double, Double, Double, Double)) 2344 | {-# INLINE viewBox #-} 2345 | viewBox = document . viewBox 2346 | 2347 | width :: Lens' c_aqpq (Maybe Number) 2348 | {-# INLINE width #-} 2349 | width = document . width 2350 | 2351 | instance HasDocument Document where 2352 | document = id 2353 | {-# INLINE definitions #-} 2354 | definitions f attr = 2355 | fmap (\y -> attr { _definitions = y }) (f $ _definitions attr) 2356 | 2357 | {-# INLINE description #-} 2358 | description f attr = 2359 | fmap (\y -> attr { _description = y }) (f $ _description attr) 2360 | 2361 | {-# INLINE documentLocation #-} 2362 | documentLocation f attr = 2363 | fmap (\y -> attr { _documentLocation = y }) (f $ _documentLocation attr) 2364 | 2365 | {-# INLINE elements #-} 2366 | elements f attr = 2367 | fmap (\y -> attr { _elements = y }) (f $ _elements attr) 2368 | 2369 | {-# INLINE height #-} 2370 | height f attr = 2371 | fmap (\y -> attr { _height = y }) (f $ _height attr) 2372 | 2373 | {-# INLINE styleRules #-} 2374 | styleRules f attr = 2375 | fmap (\y -> attr { _styleRules = y }) (f $ _styleRules attr) 2376 | 2377 | {-# INLINE viewBox #-} 2378 | viewBox f attr = 2379 | fmap (\y -> attr { _viewBox = y }) (f $ _viewBox attr) 2380 | 2381 | {-# INLINE width #-} 2382 | width f attr = 2383 | fmap (\y -> attr { _width = y }) (f $ _width attr) 2384 | 2385 | -- | Calculate the document size in function of the 2386 | -- different available attributes in the document. 2387 | documentSize :: Dpi -> Document -> (Int, Int) 2388 | documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) 2389 | , _width = Just (Percent pw) 2390 | , _height = Just (Percent ph) 2391 | } = 2392 | (floor $ dx * pw, floor $ dy * ph) 2393 | where 2394 | dx = abs $ x2 - x1 2395 | dy = abs $ y2 - y1 2396 | documentSize _ Document { _width = Just (Num w) 2397 | , _height = Just (Num h) } = (floor w, floor h) 2398 | documentSize dpi doc@(Document { _width = Just w 2399 | , _height = Just h }) = 2400 | documentSize dpi $ doc 2401 | { _width = Just $ toUserUnit dpi w 2402 | , _height = Just $ toUserUnit dpi h } 2403 | documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } = 2404 | (floor . abs $ x2 - x1, floor . abs $ y2 - y1) 2405 | documentSize _ _ = (1, 1) 2406 | 2407 | mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a 2408 | mayMerge (Just a) (Just b) = Just $ mappend a b 2409 | mayMerge _ b@(Just _) = b 2410 | mayMerge a Nothing = a 2411 | 2412 | instance Semigroup DrawAttributes where 2413 | (<>) a b = DrawAttributes 2414 | { _strokeWidth = (mappend `on` _strokeWidth) a b 2415 | , _strokeColor = (mappend `on` _strokeColor) a b 2416 | , _strokeLineCap = (mappend `on` _strokeLineCap) a b 2417 | , _strokeOpacity = (opacityMappend `on` _strokeOpacity) a b 2418 | , _strokeLineJoin = (mappend `on` _strokeLineJoin) a b 2419 | , _strokeMiterLimit = (mappend `on` _strokeMiterLimit) a b 2420 | , _fillColor = (mappend `on` _fillColor) a b 2421 | , _fillOpacity = (opacityMappend `on` _fillOpacity) a b 2422 | , _fontSize = (mappend `on` _fontSize) a b 2423 | , _transform = (mayMerge `on` _transform) a b 2424 | , _fillRule = (mappend `on` _fillRule) a b 2425 | , _attrClass = _attrClass b 2426 | , _attrId = _attrId b 2427 | , _groupOpacity = _groupOpacity b 2428 | , _strokeOffset = (mappend `on` _strokeOffset) a b 2429 | , _strokeDashArray = (mappend `on` _strokeDashArray) a b 2430 | , _fontFamily = (mappend `on` _fontFamily) a b 2431 | , _fontStyle = (mappend `on` _fontStyle) a b 2432 | , _textAnchor = (mappend `on` _textAnchor) a b 2433 | , _maskRef = (mappend `on` _maskRef) a b 2434 | , _clipPathRef = (mappend `on` _clipPathRef) a b 2435 | , _clipRule = (mappend `on` _clipRule) a b 2436 | , _markerStart = (mappend `on` _markerStart) a b 2437 | , _markerMid = (mappend `on` _markerMid) a b 2438 | , _markerEnd = (mappend `on` _markerEnd) a b 2439 | } 2440 | where 2441 | opacityMappend Nothing Nothing = Nothing 2442 | opacityMappend (Just v) Nothing = Just v 2443 | opacityMappend Nothing (Just v) = Just v 2444 | opacityMappend (Just v) (Just v2) = Just $ v * v2 2445 | 2446 | instance Monoid DrawAttributes where 2447 | mappend = (<>) 2448 | mempty = DrawAttributes 2449 | { _strokeWidth = Last Nothing 2450 | , _strokeColor = Last Nothing 2451 | , _strokeOpacity = Nothing 2452 | , _strokeLineCap = Last Nothing 2453 | , _strokeLineJoin = Last Nothing 2454 | , _strokeMiterLimit = Last Nothing 2455 | , _fillColor = Last Nothing 2456 | , _groupOpacity = Nothing 2457 | , _fillOpacity = Nothing 2458 | , _fontSize = Last Nothing 2459 | , _fontFamily = Last Nothing 2460 | , _fontStyle = Last Nothing 2461 | , _transform = Nothing 2462 | , _fillRule = Last Nothing 2463 | , _attrClass = mempty 2464 | , _attrId = Nothing 2465 | , _strokeOffset = Last Nothing 2466 | , _strokeDashArray = Last Nothing 2467 | , _textAnchor = Last Nothing 2468 | , _maskRef = Last Nothing 2469 | , _clipPathRef = Last Nothing 2470 | , _clipRule = Last Nothing 2471 | 2472 | , _markerStart = Last Nothing 2473 | , _markerMid = Last Nothing 2474 | , _markerEnd = Last Nothing 2475 | } 2476 | 2477 | instance WithDefaultSvg DrawAttributes where 2478 | defaultSvg = mempty 2479 | 2480 | instance CssMatcheable Tree where 2481 | cssAttribOf _ _ = Nothing 2482 | cssClassOf = view (drawAttr . attrClass) 2483 | cssIdOf = fmap T.pack . view (drawAttr . attrId) 2484 | cssNameOf = nameOfTree 2485 | 2486 | -------------------------------------------------------------------------- 2487 | --- Dumped 2488 | -------------------------------------------------------------------------- 2489 | -- makeClassy ''PreserveAspectRatio 2490 | -- 2491 | -- | Lenses for the PreserveAspectRatio type 2492 | class HasPreserveAspectRatio a where 2493 | preserveAspectRatio :: Lens' a PreserveAspectRatio 2494 | aspectRatioAlign :: Lens' a Alignment 2495 | {-# INLINE aspectRatioAlign #-} 2496 | aspectRatioAlign = preserveAspectRatio . aspectRatioAlign 2497 | 2498 | aspectRatioDefer :: Lens' a Bool 2499 | {-# INLINE aspectRatioDefer #-} 2500 | aspectRatioDefer = preserveAspectRatio . aspectRatioDefer 2501 | 2502 | aspectRatioMeetSlice :: Lens' a (Maybe MeetSlice) 2503 | {-# INLINE aspectRatioMeetSlice #-} 2504 | aspectRatioMeetSlice = preserveAspectRatio . aspectRatioMeetSlice 2505 | 2506 | instance HasPreserveAspectRatio PreserveAspectRatio where 2507 | preserveAspectRatio = id 2508 | {-# INLINE aspectRatioAlign #-} 2509 | aspectRatioAlign f attr = 2510 | fmap (\y -> attr { _aspectRatioAlign = y }) (f $ _aspectRatioAlign attr) 2511 | 2512 | {-# INLINE aspectRatioDefer #-} 2513 | aspectRatioDefer f attr = 2514 | fmap (\y -> attr { _aspectRatioDefer = y }) (f $ _aspectRatioDefer attr) 2515 | 2516 | {-# INLINE aspectRatioMeetSlice #-} 2517 | aspectRatioMeetSlice f attr = 2518 | fmap (\y -> attr { _aspectRatioMeetSlice = y }) (f $ _aspectRatioMeetSlice attr) 2519 | 2520 | -- makeClassy ''DrawAttributes 2521 | -- | Lenses for the DrawAttributes type. 2522 | class HasDrawAttributes a where 2523 | drawAttributes :: Lens' a DrawAttributes 2524 | attrClass :: Lens' a [T.Text] 2525 | {-# INLINE attrClass #-} 2526 | attrClass = drawAttributes . attrClass 2527 | 2528 | attrId :: Lens' a (Maybe String) 2529 | {-# INLINE attrId #-} 2530 | attrId = drawAttributes . attrId 2531 | 2532 | clipPathRef :: Lens' a (Last ElementRef) 2533 | {-# INLINE clipPathRef #-} 2534 | clipPathRef = drawAttributes . clipPathRef 2535 | 2536 | clipRule :: Lens' a (Last FillRule) 2537 | {-# INLINE clipRule #-} 2538 | clipRule = drawAttributes . clipRule 2539 | 2540 | fillColor :: Lens' a (Last Texture) 2541 | {-# INLINE fillColor #-} 2542 | fillColor = drawAttributes . fillColor 2543 | 2544 | fillOpacity :: Lens' a (Maybe Float) 2545 | {-# INLINE fillOpacity #-} 2546 | fillOpacity = drawAttributes . fillOpacity 2547 | 2548 | fillRule :: Lens' a (Last FillRule) 2549 | {-# INLINE fillRule #-} 2550 | fillRule = drawAttributes . fillRule 2551 | 2552 | fontFamily :: Lens' a (Last [String]) 2553 | {-# INLINE fontFamily #-} 2554 | fontFamily = drawAttributes . fontFamily 2555 | 2556 | fontSize :: Lens' a (Last Number) 2557 | {-# INLINE fontSize #-} 2558 | fontSize = drawAttributes . fontSize 2559 | 2560 | fontStyle :: Lens' a (Last FontStyle) 2561 | {-# INLINE fontStyle #-} 2562 | fontStyle = drawAttributes . fontStyle 2563 | 2564 | groupOpacity :: Lens' a (Maybe Float) 2565 | {-# INLINE groupOpacity #-} 2566 | groupOpacity = drawAttributes . groupOpacity 2567 | 2568 | markerEnd :: Lens' a (Last ElementRef) 2569 | {-# INLINE markerEnd #-} 2570 | markerEnd = drawAttributes . markerEnd 2571 | 2572 | markerMid :: Lens' a (Last ElementRef) 2573 | {-# INLINE markerMid #-} 2574 | markerMid = drawAttributes . markerMid 2575 | 2576 | markerStart :: Lens' a (Last ElementRef) 2577 | {-# INLINE markerStart #-} 2578 | markerStart = drawAttributes . markerStart 2579 | 2580 | maskRef :: Lens' a (Last ElementRef) 2581 | {-# INLINE maskRef #-} 2582 | maskRef = drawAttributes . maskRef 2583 | 2584 | strokeColor :: Lens' a (Last Texture) 2585 | {-# INLINE strokeColor #-} 2586 | strokeColor = drawAttributes . strokeColor 2587 | 2588 | strokeDashArray :: Lens' a (Last [Number]) 2589 | {-# INLINE strokeDashArray #-} 2590 | strokeDashArray = drawAttributes . strokeDashArray 2591 | 2592 | strokeLineCap :: Lens' a (Last Cap) 2593 | {-# INLINE strokeLineCap #-} 2594 | strokeLineCap = drawAttributes . strokeLineCap 2595 | 2596 | strokeLineJoin :: Lens' a (Last LineJoin) 2597 | {-# INLINE strokeLineJoin #-} 2598 | strokeLineJoin = drawAttributes . strokeLineJoin 2599 | 2600 | strokeMiterLimit :: Lens' a (Last Double) 2601 | {-# INLINE strokeMiterLimit #-} 2602 | strokeMiterLimit = drawAttributes . strokeMiterLimit 2603 | 2604 | strokeOffset :: Lens' a (Last Number) 2605 | {-# INLINE strokeOffset #-} 2606 | strokeOffset = drawAttributes . strokeOffset 2607 | 2608 | strokeOpacity :: Lens' a (Maybe Float) 2609 | {-# INLINE strokeOpacity #-} 2610 | strokeOpacity = drawAttributes . strokeOpacity 2611 | 2612 | strokeWidth :: Lens' a (Last Number) 2613 | {-# INLINE strokeWidth #-} 2614 | strokeWidth = drawAttributes . strokeWidth 2615 | 2616 | textAnchor :: Lens' a (Last TextAnchor) 2617 | {-# INLINE textAnchor #-} 2618 | textAnchor = drawAttributes . textAnchor 2619 | 2620 | transform :: Lens' a (Maybe [Transformation]) 2621 | {-# INLINE transform #-} 2622 | transform = drawAttributes . transform 2623 | 2624 | instance HasDrawAttributes DrawAttributes where 2625 | {-# INLINE attrId #-} 2626 | {-# INLINE clipPathRef #-} 2627 | {-# INLINE clipRule #-} 2628 | {-# INLINE fillColor #-} 2629 | {-# INLINE fillOpacity #-} 2630 | {-# INLINE fillRule #-} 2631 | {-# INLINE fontFamily #-} 2632 | {-# INLINE fontSize #-} 2633 | {-# INLINE fontStyle #-} 2634 | {-# INLINE groupOpacity #-} 2635 | {-# INLINE markerEnd #-} 2636 | {-# INLINE markerMid #-} 2637 | {-# INLINE markerStart #-} 2638 | {-# INLINE maskRef #-} 2639 | {-# INLINE strokeColor #-} 2640 | {-# INLINE strokeDashArray #-} 2641 | {-# INLINE strokeLineCap #-} 2642 | {-# INLINE strokeLineJoin #-} 2643 | {-# INLINE strokeMiterLimit #-} 2644 | {-# INLINE strokeOffset #-} 2645 | {-# INLINE strokeOpacity #-} 2646 | {-# INLINE strokeWidth #-} 2647 | {-# INLINE textAnchor #-} 2648 | {-# INLINE transform #-} 2649 | drawAttributes = id 2650 | 2651 | {-# INLINE attrClass #-} 2652 | attrClass f attr = 2653 | fmap (\y -> attr { _attrClass = y }) (f (_attrClass attr)) 2654 | attrId f attr = 2655 | fmap (\y -> attr { _attrId = y }) (f $ _attrId attr) 2656 | clipPathRef f attr = 2657 | fmap (\y -> attr { _clipPathRef = y }) (f $ _clipPathRef attr) 2658 | clipRule f attr = 2659 | fmap (\y -> attr { _clipRule = y }) (f $ _clipRule attr) 2660 | fillColor f attr = 2661 | fmap (\y -> attr { _fillColor = y }) (f $ _fillColor attr) 2662 | fillOpacity f attr = 2663 | fmap (\y -> attr { _fillOpacity = y }) (f $ _fillOpacity attr) 2664 | fillRule f attr = 2665 | fmap (\y -> attr { _fillRule = y }) (f $ _fillRule attr) 2666 | fontFamily f attr = 2667 | fmap (\y -> attr { _fontFamily = y }) (f $ _fontFamily attr) 2668 | fontSize f attr = 2669 | fmap (\y -> attr { _fontSize = y }) (f $ _fontSize attr) 2670 | fontStyle f attr = 2671 | fmap (\y -> attr { _fontStyle = y }) (f $ _fontStyle attr) 2672 | groupOpacity f attr = 2673 | fmap (\y -> attr { _groupOpacity = y }) (f $ _groupOpacity attr) 2674 | markerEnd f attr = 2675 | fmap (\y -> attr { _markerEnd = y }) (f $ _markerEnd attr) 2676 | markerMid f attr = 2677 | fmap (\y -> attr { _markerMid = y }) (f $ _markerMid attr) 2678 | markerStart f attr = 2679 | fmap (\y -> attr { _markerStart = y }) (f $ _markerStart attr) 2680 | maskRef f attr = 2681 | fmap (\y -> attr { _maskRef = y }) (f $ _maskRef attr) 2682 | strokeColor f attr = 2683 | fmap (\y -> attr { _strokeColor = y }) (f $ _strokeColor attr) 2684 | strokeDashArray f attr = 2685 | fmap (\y -> attr { _strokeDashArray = y }) (f $ _strokeDashArray attr) 2686 | strokeLineCap f attr = 2687 | fmap (\y -> attr { _strokeLineCap = y }) (f $ _strokeLineCap attr) 2688 | strokeLineJoin f attr = 2689 | fmap (\y -> attr { _strokeLineJoin = y }) (f $ _strokeLineJoin attr) 2690 | strokeMiterLimit f attr = 2691 | fmap (\y -> attr { _strokeMiterLimit = y }) (f $ _strokeMiterLimit attr) 2692 | strokeOffset f attr = 2693 | fmap (\y -> attr { _strokeOffset = y }) (f $ _strokeOffset attr) 2694 | strokeOpacity f attr = 2695 | fmap (\y -> attr { _strokeOpacity = y }) (f $ _strokeOpacity attr) 2696 | strokeWidth f attr = 2697 | fmap (\y -> attr { _strokeWidth = y }) (f $ _strokeWidth attr) 2698 | textAnchor f attr = 2699 | fmap (\y -> attr { _textAnchor = y }) (f $ _textAnchor attr) 2700 | transform f attr = 2701 | fmap (\y -> attr { _transform = y }) (f $ _transform attr) 2702 | 2703 | -------------------------------------------------------------------------------- /src/Graphics/Svg/XmlParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | module Graphics.Svg.XmlParser( xmlOfDocument 8 | , unparseDocument 9 | 10 | , SvgAttributeLens( .. ) 11 | , drawAttributesList 12 | ) where 13 | 14 | 15 | #if !MIN_VERSION_base(4,6,0) 16 | import Text.Read( reads ) 17 | #else 18 | import Text.Read( readMaybe ) 19 | #endif 20 | 21 | #if !MIN_VERSION_base(4,8,0) 22 | import Control.Applicative( pure, (<$>), (<$), (<*>) ) 23 | import Data.Foldable( foldMap ) 24 | import Data.Monoid( mempty ) 25 | #endif 26 | 27 | import Control.Applicative( (<|>), many ) 28 | 29 | import Control.Lens hiding( transform, children, elements, element ) 30 | import Control.Monad.State.Strict( State, runState, modify, gets ) 31 | import Data.Maybe( fromMaybe, catMaybes ) 32 | import Data.Monoid( Last( Last ), getLast, (<>) ) 33 | import Data.List( foldl', intercalate ) 34 | import Text.XML.Light.Proc( findAttrBy, elChildren, strContent ) 35 | import qualified Text.XML.Light as X 36 | import qualified Data.Text as T 37 | import qualified Data.Text.Lazy as TL 38 | import qualified Data.Text.Lazy.Builder as TB 39 | import qualified Data.Map as M 40 | import Data.Attoparsec.Text( Parser, string, parseOnly, many1 ) 41 | import Codec.Picture( PixelRGBA8( .. ) ) 42 | import Graphics.Svg.Types 43 | import Graphics.Svg.PathParser 44 | import Graphics.Svg.ColorParser 45 | import Graphics.Svg.CssTypes( CssDeclaration( .. ) 46 | , CssElement( .. ) 47 | , CssRule 48 | , tserialize 49 | ) 50 | import Graphics.Svg.CssParser( complexNumber 51 | , num 52 | , ruleSet 53 | , dashArray 54 | , styleString 55 | , numberList ) 56 | 57 | import Text.Printf( printf ) 58 | 59 | {-import Debug.Trace-} 60 | 61 | #if !MIN_VERSION_base(4,6,0) 62 | readMaybe :: Read a => String -> Maybe a 63 | readMaybe str = case reads str of 64 | [] -> Nothing 65 | (x, _):_ -> Just x 66 | #endif 67 | 68 | nodeName :: X.Element -> String 69 | nodeName = X.qName . X.elName 70 | 71 | attributeFinder :: String -> X.Element -> Maybe String 72 | attributeFinder str = 73 | findAttrBy (\a -> X.qName a == str) 74 | 75 | -- | Helper class to help simplify parsing code 76 | -- for various attributes. 77 | class ParseableAttribute a where 78 | aparse :: String -> Maybe a 79 | aserialize :: a -> Maybe String 80 | 81 | instance ParseableAttribute v => ParseableAttribute (Maybe v) where 82 | aparse = fmap Just . aparse 83 | aserialize = (>>= aserialize) 84 | 85 | instance ParseableAttribute v => ParseableAttribute (Last v) where 86 | aparse = fmap Last . aparse 87 | aserialize = aserialize . getLast 88 | 89 | instance ParseableAttribute String where 90 | aparse = Just 91 | aserialize = Just 92 | 93 | instance ParseableAttribute Number where 94 | aparse = parseMayStartDot complexNumber 95 | aserialize = Just . serializeNumber 96 | 97 | instance ParseableAttribute [Number] where 98 | aparse = parse dashArray 99 | aserialize = Just . serializeDashArray 100 | 101 | instance ParseableAttribute PixelRGBA8 where 102 | aparse = parse colorParser 103 | aserialize = Just . colorSerializer 104 | 105 | instance ParseableAttribute [PathCommand] where 106 | aparse = parse pathParser 107 | aserialize = Just . serializeCommands 108 | 109 | instance ParseableAttribute GradientPathCommand where 110 | aparse = parse gradientCommand 111 | aserialize = Just . serializeGradientCommand 112 | 113 | instance ParseableAttribute [RPoint] where 114 | aparse = parse pointData 115 | aserialize = Just . serializePoints 116 | 117 | instance ParseableAttribute Double where 118 | aparse = parseMayStartDot num 119 | aserialize v = Just $ printf "%g" v 120 | 121 | instance ParseableAttribute Texture where 122 | aparse = parse textureParser 123 | aserialize = Just . textureSerializer 124 | 125 | instance ParseableAttribute [Transformation] where 126 | aparse = parse $ many transformParser 127 | aserialize = Just . serializeTransformations 128 | 129 | instance ParseableAttribute Alignment where 130 | aparse s = Just $ case s of 131 | "none" -> AlignNone 132 | "xMinYMin" -> AlignxMinYMin 133 | "xMidYMin" -> AlignxMidYMin 134 | "xMaxYMin" -> AlignxMaxYMin 135 | "xMinYMid" -> AlignxMinYMid 136 | "xMidYMid" -> AlignxMidYMid 137 | "xMaxYMid" -> AlignxMaxYMid 138 | "xMinYMax" -> AlignxMinYMax 139 | "xMidYMax" -> AlignxMidYMax 140 | "xMaxYMax" -> AlignxMaxYMax 141 | _ -> _aspectRatioAlign defaultSvg 142 | 143 | aserialize v = Just $ case v of 144 | AlignNone -> "none" 145 | AlignxMinYMin -> "xMinYMin" 146 | AlignxMidYMin -> "xMidYMin" 147 | AlignxMaxYMin -> "xMaxYMin" 148 | AlignxMinYMid -> "xMinYMid" 149 | AlignxMidYMid -> "xMidYMid" 150 | AlignxMaxYMid -> "xMaxYMid" 151 | AlignxMinYMax -> "xMinYMax" 152 | AlignxMidYMax -> "xMidYMax" 153 | AlignxMaxYMax -> "xMaxYMax" 154 | 155 | instance ParseableAttribute MeshGradientType where 156 | aparse s = Just $ case s of 157 | "bilinear" -> GradientBilinear 158 | "bicubic" -> GradientBicubic 159 | _ -> GradientBilinear 160 | 161 | aserialize v = Just $ case v of 162 | GradientBilinear -> "bilinear" 163 | GradientBicubic -> "bicubic" 164 | 165 | instance ParseableAttribute MeetSlice where 166 | aparse s = case s of 167 | "meet" -> Just Meet 168 | "slice" -> Just Slice 169 | _ -> Nothing 170 | 171 | aserialize v = Just $ case v of 172 | Meet -> "meet" 173 | Slice -> "slice" 174 | 175 | instance ParseableAttribute PreserveAspectRatio where 176 | aserialize v = Just $ defer <> align <> meetSlice where 177 | defer = if _aspectRatioDefer v then "defer " else "" 178 | align = fromMaybe "" . aserialize $ _aspectRatioAlign v 179 | meetSlice = fromMaybe "" $ aserialize =<< _aspectRatioMeetSlice v 180 | 181 | aparse s = case words s of 182 | [] -> Nothing 183 | [align] -> Just $ defaultSvg { _aspectRatioAlign = alignOf align } 184 | ["defer", align] -> 185 | Just $ defaultSvg 186 | { _aspectRatioDefer = True 187 | , _aspectRatioAlign = alignOf align 188 | } 189 | [align, meet] -> 190 | Just $ defaultSvg 191 | { _aspectRatioMeetSlice = aparse meet 192 | , _aspectRatioAlign = alignOf align 193 | } 194 | ["defer", align, meet] -> 195 | Just $ PreserveAspectRatio 196 | { _aspectRatioDefer = True 197 | , _aspectRatioAlign = alignOf align 198 | , _aspectRatioMeetSlice = aparse meet 199 | } 200 | _ -> Nothing 201 | where 202 | alignOf = fromMaybe (_aspectRatioAlign defaultSvg) . aparse 203 | 204 | instance ParseableAttribute Cap where 205 | aparse s = case s of 206 | "butt" -> Just CapButt 207 | "round" -> Just CapRound 208 | "square" -> Just CapSquare 209 | _ -> Nothing 210 | 211 | aserialize c = Just $ case c of 212 | CapButt -> "butt" 213 | CapRound -> "round" 214 | CapSquare -> "square" 215 | 216 | instance ParseableAttribute TextAnchor where 217 | aparse s = case s of 218 | "middle" -> Just TextAnchorMiddle 219 | "start" -> Just TextAnchorStart 220 | "end" -> Just TextAnchorEnd 221 | _ -> Nothing 222 | 223 | aserialize t = Just $ case t of 224 | TextAnchorMiddle -> "middle" 225 | TextAnchorStart -> "start" 226 | TextAnchorEnd -> "end" 227 | 228 | instance ParseableAttribute ElementRef where 229 | aparse s = case parseOnly pa $ T.pack s of 230 | Left _ -> Nothing 231 | Right v -> Just v 232 | where 233 | pa = (RefNone <$ string "none") 234 | <|> (Ref <$> urlRef) 235 | 236 | aserialize c = Just $ case c of 237 | Ref r -> "url(#" <> r <> ")" 238 | RefNone -> "none" 239 | 240 | instance ParseableAttribute LineJoin where 241 | aparse s = case s of 242 | "miter" -> Just JoinMiter 243 | "round" -> Just JoinRound 244 | "bevel" -> Just JoinBevel 245 | _ -> Nothing 246 | 247 | aserialize j = Just $ case j of 248 | JoinMiter -> "miter" 249 | JoinRound -> "round" 250 | JoinBevel -> "bevel" 251 | 252 | instance ParseableAttribute CoordinateUnits where 253 | aparse s = case s of 254 | "userSpaceOnUse" -> Just CoordUserSpace 255 | "objectBoundingBox" -> Just CoordBoundingBox 256 | _ -> Just CoordBoundingBox 257 | 258 | aserialize uni = Just $ case uni of 259 | CoordUserSpace -> "userSpaceOnUse" 260 | CoordBoundingBox -> "objectBoundingBox" 261 | 262 | instance ParseableAttribute Spread where 263 | aparse s = case s of 264 | "pad" -> Just SpreadPad 265 | "reflect" -> Just SpreadReflect 266 | "repeat" -> Just SpreadRepeat 267 | _ -> Nothing 268 | 269 | aserialize s = Just $ case s of 270 | SpreadPad -> "pad" 271 | SpreadReflect -> "reflect" 272 | SpreadRepeat -> "repeat" 273 | 274 | instance ParseableAttribute FillRule where 275 | aparse s = case s of 276 | "nonzero" -> Just FillNonZero 277 | "evenodd" -> Just FillEvenOdd 278 | _ -> Nothing 279 | 280 | aserialize f = Just $ case f of 281 | FillNonZero -> "nonzero" 282 | FillEvenOdd -> "evenodd" 283 | 284 | instance ParseableAttribute TextAdjust where 285 | aparse s = Just $ case s of 286 | "spacing" -> TextAdjustSpacing 287 | "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs 288 | _ -> TextAdjustSpacing 289 | 290 | aserialize a = Just $ case a of 291 | TextAdjustSpacing -> "spacing" 292 | TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs" 293 | 294 | instance ParseableAttribute MarkerUnit where 295 | aparse s = case s of 296 | "strokeWidth" -> Just MarkerUnitStrokeWidth 297 | "userSpaceOnUse" -> Just MarkerUnitUserSpaceOnUse 298 | _ -> Nothing 299 | 300 | aserialize u = Just $ case u of 301 | MarkerUnitStrokeWidth -> "strokeWidth" 302 | MarkerUnitUserSpaceOnUse -> "userSpaceOnUse" 303 | 304 | instance ParseableAttribute Overflow where 305 | aparse s = case s of 306 | "visible" -> Just OverflowVisible 307 | "hidden" -> Just OverflowHidden 308 | _ -> Nothing 309 | 310 | aserialize u = Just $ case u of 311 | OverflowVisible -> "visible" 312 | OverflowHidden -> "hidden" 313 | 314 | instance ParseableAttribute MarkerOrientation where 315 | aparse s = case (s, readMaybe s) of 316 | ("auto", _) -> Just OrientationAuto 317 | (_, Just f) -> Just $ OrientationAngle f 318 | _ -> Nothing 319 | 320 | aserialize s = Just $ case s of 321 | OrientationAuto -> "auto" 322 | OrientationAngle f -> show f 323 | 324 | instance ParseableAttribute (Double, Double, Double, Double) where 325 | aparse = parse viewBoxParser 326 | aserialize = Just . serializeViewBox 327 | 328 | instance ParseableAttribute TextPathMethod where 329 | aparse s = case s of 330 | "align" -> Just TextPathAlign 331 | "stretch" -> Just TextPathStretch 332 | _ -> Nothing 333 | aserialize m = Just $ case m of 334 | TextPathAlign -> "align" 335 | TextPathStretch -> "stretch" 336 | 337 | instance ParseableAttribute TextPathSpacing where 338 | aparse s = case s of 339 | "auto" -> Just TextPathSpacingAuto 340 | "exact" -> Just TextPathSpacingExact 341 | _ -> Nothing 342 | 343 | aserialize s = Just $ case s of 344 | TextPathSpacingAuto -> "auto" 345 | TextPathSpacingExact -> "exact" 346 | 347 | parse :: Parser a -> String -> Maybe a 348 | parse p str = case parseOnly p (T.pack str) of 349 | Left _ -> Nothing 350 | Right r -> Just r 351 | 352 | parseMayStartDot :: Parser a -> String -> Maybe a 353 | parseMayStartDot p l@('.':_) = parse p ('0':l) 354 | parseMayStartDot p l = parse p l 355 | 356 | xmlUpdate :: (XMLUpdatable a) => a -> X.Element -> a 357 | xmlUpdate initial el = foldl' grab initial attributes 358 | where 359 | grab value updater = 360 | case attributeFinder (_attributeName updater) el of 361 | Nothing -> value 362 | Just v -> _attributeUpdater updater value v 363 | 364 | xmlUnparse :: (XMLUpdatable a) => X.Element -> a 365 | xmlUnparse = xmlUpdate defaultSvg 366 | 367 | xmlUnparseWithDrawAttr 368 | :: (XMLUpdatable a, WithDrawAttributes a) 369 | => X.Element -> a 370 | xmlUnparseWithDrawAttr e = 371 | xmlUnparse e & drawAttr .~ xmlUnparse e 372 | 373 | data SvgAttributeLens t = SvgAttributeLens 374 | { _attributeName :: String 375 | , _attributeUpdater :: t -> String -> t 376 | , _attributeSerializer :: t -> Maybe String 377 | } 378 | 379 | class (WithDefaultSvg treeNode) => XMLUpdatable treeNode where 380 | xmlTagName :: treeNode -> String 381 | attributes :: [SvgAttributeLens treeNode] 382 | 383 | serializeTreeNode :: treeNode -> Maybe X.Element 384 | 385 | setChildren :: X.Element -> [X.Content] -> X.Element 386 | setChildren xNode children = xNode { X.elContent = children } 387 | 388 | updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> Maybe X.Element -> Maybe X.Element 389 | updateWithAccessor _ _ Nothing = Nothing 390 | updateWithAccessor accessor node (Just xNode) = 391 | Just . setChildren xNode . fmap X.Elem . catMaybes $ serializeTreeNode <$> accessor node 392 | 393 | genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> Maybe X.Element 394 | genericSerializeNode node = 395 | Just . X.unode (xmlTagName node) $ concatMap generateAttribute attributes 396 | where 397 | generateAttribute attr = case _attributeSerializer attr node of 398 | Nothing -> [] 399 | Just str -> return X.Attr 400 | { X.attrKey = xName $ _attributeName attr 401 | , X.attrVal = str 402 | } 403 | where 404 | xName "href" = 405 | X.QName { X.qName = "href" 406 | , X.qURI = Nothing 407 | , X.qPrefix = Just "xlink" } 408 | xName h = X.unqual h 409 | 410 | 411 | mergeAttributes :: X.Element -> X.Element -> X.Element 412 | mergeAttributes thisXml otherXml = 413 | thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml } 414 | 415 | genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode) 416 | => treeNode -> Maybe X.Element 417 | genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where 418 | thisXml = genericSerializeNode node 419 | drawAttrNode = genericSerializeNode $ node ^. drawAttr 420 | 421 | type CssUpdater a = 422 | a -> [[CssElement]] -> a 423 | 424 | opacitySetter :: String -> Lens' a (Maybe Float) -> SvgAttributeLens a 425 | opacitySetter attribute elLens = 426 | SvgAttributeLens attribute updater serializer 427 | where 428 | serializer a = printf "%g" <$> a ^. elLens 429 | updater el str = case parseMayStartDot num str of 430 | Nothing -> el 431 | Just v -> el & elLens .~ Just (realToFrac v) 432 | 433 | type Serializer e = e -> Maybe String 434 | 435 | parserSetter :: String -> Lens' a e -> (String -> Maybe e) -> Serializer e 436 | -> SvgAttributeLens a 437 | parserSetter attribute elLens parser serialize = 438 | SvgAttributeLens attribute updater serializer 439 | where 440 | updater el str = case parser str of 441 | Nothing -> el 442 | Just v -> el & elLens .~ v 443 | 444 | serializer a = serialize $ a ^. elLens 445 | 446 | parseIn :: (Eq a, WithDefaultSvg s, ParseableAttribute a) 447 | => String -> Lens' s a -> SvgAttributeLens s 448 | parseIn attribute elLens = 449 | SvgAttributeLens attribute updater serializer 450 | where 451 | updater el str = case aparse str of 452 | Nothing -> el 453 | Just v -> el & elLens .~ v 454 | 455 | serializer a 456 | | v /= defaultVal = aserialize v 457 | | otherwise = Nothing 458 | where 459 | v = a ^. elLens 460 | defaultVal = defaultSvg ^. elLens 461 | 462 | parserLastSetter :: String -> Lens' a (Last e) -> (String -> Maybe e) -> Serializer e 463 | -> SvgAttributeLens a 464 | parserLastSetter attribute elLens parser serialize = 465 | SvgAttributeLens attribute updater serializer 466 | where 467 | updater el str = case parser str of 468 | Nothing -> el 469 | Just v -> el & elLens .~ Last (Just v) 470 | 471 | serializer a = getLast (a ^. elLens) >>= serialize 472 | 473 | classSetter :: SvgAttributeLens DrawAttributes 474 | classSetter = SvgAttributeLens "class" updater serializer 475 | where 476 | updater el str = 477 | el & attrClass .~ (T.split (== ' ') $ T.pack str) 478 | 479 | serializer a = case a ^. attrClass of 480 | [] -> Nothing 481 | lst -> Just . T.unpack $ T.intercalate " " lst 482 | 483 | cssUniqueNumber :: ASetter el el 484 | a (Last Number) 485 | -> CssUpdater el 486 | cssUniqueNumber setter attr ((CssNumber n:_):_) = 487 | attr & setter .~ Last (Just n) 488 | cssUniqueNumber _ attr _ = attr 489 | 490 | cssUniqueFloat :: (Fractional n) 491 | => ASetter el el a (Maybe n) 492 | -> CssUpdater el 493 | cssUniqueFloat setter attr ((CssNumber (Num n):_):_) = 494 | attr & setter .~ Just (realToFrac n) 495 | cssUniqueFloat _ attr _ = attr 496 | 497 | cssUniqueMayFloat :: ASetter el el a (Last Double) 498 | -> CssUpdater el 499 | cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) = 500 | attr & setter .~ Last (Just n) 501 | cssUniqueMayFloat _ attr _ = attr 502 | 503 | cssIdentAttr :: ParseableAttribute a => Lens' el a -> CssUpdater el 504 | cssIdentAttr setter attr ((CssIdent i:_):_) = case aparse $ T.unpack i of 505 | Nothing -> attr 506 | Just v -> attr & setter .~ v 507 | cssIdentAttr _ attr _ = attr 508 | 509 | fontFamilyParser :: CssUpdater DrawAttributes 510 | fontFamilyParser attr (lst:_) = attr & fontFamily .~ fontNames 511 | where 512 | fontNames = Last . Just $ T.unpack <$> extractString lst 513 | 514 | extractString [] = [] 515 | extractString (CssIdent n:rest) = n : extractString rest 516 | extractString (CssString n:rest) = n : extractString rest 517 | extractString (_:rest) = extractString rest 518 | fontFamilyParser attr _ = attr 519 | 520 | 521 | cssUniqueTexture :: ASetter el el 522 | a (Last Texture) 523 | -> CssUpdater el 524 | cssUniqueTexture setter attr css = case css of 525 | ((CssIdent "none":_):_) -> attr & setter .~ Last (Just FillNone) 526 | ((CssColor c:_):_) -> attr & setter .~ Last (Just $ ColorRef c) 527 | ((CssFunction "url" [CssReference c]:_):_) -> 528 | attr & setter .~ Last (Just . TextureRef $ T.unpack c) 529 | _ -> attr 530 | 531 | cssUniqueColor :: ASetter el el a PixelRGBA8 -> CssUpdater el 532 | cssUniqueColor setter attr css = case css of 533 | ((CssColor c:_):_) -> attr & setter .~ c 534 | _ -> attr 535 | 536 | cssElementRefSetter :: Lens' el (Last ElementRef) -> CssUpdater el 537 | cssElementRefSetter setter attr ((CssFunction "url" [CssReference c]:_):_) = 538 | attr & setter .~ Last (Just . Ref $ T.unpack c) 539 | cssElementRefSetter setter attr ((CssIdent "none":_):_) = 540 | attr & setter .~ Last (Just RefNone) 541 | cssElementRefSetter _ attr _ = attr 542 | 543 | cssMayStringSetter :: ASetter el el a (Maybe String) -> CssUpdater el 544 | cssMayStringSetter setter attr ((CssIdent i:_):_) = 545 | attr & setter .~ Just (T.unpack i) 546 | cssMayStringSetter setter attr ((CssString i:_):_) = 547 | attr & setter .~ Just (T.unpack i) 548 | cssMayStringSetter _ attr _ = attr 549 | 550 | cssNullSetter :: CssUpdater a 551 | cssNullSetter attr _ = attr 552 | 553 | cssDashArray :: ASetter el el a (Last [Number]) -> CssUpdater el 554 | cssDashArray setter attr (lst:_) = 555 | case [n | CssNumber n <- lst ] of 556 | [] -> attr 557 | v -> attr & setter .~ Last (Just v) 558 | cssDashArray _ attr _ = attr 559 | 560 | 561 | drawAttributesList :: [(SvgAttributeLens DrawAttributes, CssUpdater DrawAttributes)] 562 | drawAttributesList = 563 | [("stroke-width" `parseIn` strokeWidth, cssUniqueNumber strokeWidth) 564 | ,("stroke" `parseIn` strokeColor, cssUniqueTexture strokeColor) 565 | ,("fill" `parseIn` fillColor, cssUniqueTexture fillColor) 566 | ,("stroke-linecap" `parseIn` strokeLineCap, cssIdentAttr strokeLineCap) 567 | ,("stroke-linejoin" `parseIn` strokeLineJoin, cssIdentAttr strokeLineJoin) 568 | ,("stroke-miterlimit" `parseIn` strokeMiterLimit, 569 | cssUniqueMayFloat strokeMiterLimit) 570 | 571 | ,("transform" `parseIn` transform, const) 572 | ,(opacitySetter "opacity" groupOpacity, cssUniqueFloat groupOpacity) 573 | ,(opacitySetter "fill-opacity" fillOpacity, cssUniqueFloat fillOpacity) 574 | ,(opacitySetter "stroke-opacity" strokeOpacity, cssUniqueFloat strokeOpacity) 575 | ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize) 576 | ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate) 577 | (Just . intercalate ", "), fontFamilyParser) 578 | 579 | ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule) 580 | ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule) 581 | ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef) 582 | ,(classSetter, cssNullSetter) -- can't set class in CSS 583 | ,("id" `parseIn` attrId, cssMayStringSetter attrId) 584 | ,("stroke-dashoffset" `parseIn` strokeOffset, 585 | cssUniqueNumber strokeOffset) 586 | ,("stroke-dasharray" `parseIn` strokeDashArray, cssDashArray strokeDashArray) 587 | ,("text-anchor" `parseIn` textAnchor, cssIdentAttr textAnchor) 588 | ,("clip-path" `parseIn` clipPathRef, cssElementRefSetter clipPathRef) 589 | ,("marker-end" `parseIn` markerEnd, cssElementRefSetter markerEnd) 590 | ,("marker-start" `parseIn` markerStart, cssElementRefSetter markerStart) 591 | ,("marker-mid" `parseIn` markerMid, cssElementRefSetter markerMid) 592 | ] 593 | where 594 | commaSeparate = 595 | fmap (T.unpack . T.strip) . T.split (',' ==) . T.pack 596 | 597 | serializeDashArray :: [Number] -> String 598 | serializeDashArray = 599 | intercalate ", " . fmap serializeNumber 600 | 601 | instance XMLUpdatable DrawAttributes where 602 | xmlTagName _ = "DRAWATTRIBUTES" 603 | attributes = 604 | styleAttribute drawAttributesList : fmap fst drawAttributesList 605 | serializeTreeNode = genericSerializeNode 606 | 607 | styleAttribute :: [(SvgAttributeLens a, CssUpdater a)] -> SvgAttributeLens a 608 | styleAttribute styleAttrs = SvgAttributeLens 609 | { _attributeName = "style" 610 | , _attributeUpdater = updater 611 | , _attributeSerializer = const Nothing 612 | } 613 | where 614 | updater attrs style = case parse styleString style of 615 | Nothing -> attrs 616 | Just decls -> foldl' applyer attrs decls 617 | 618 | cssUpdaters = [(T.pack $ _attributeName n, u) | (n, u) <- styleAttrs] 619 | applyer value (CssDeclaration txt elems) = 620 | case lookup txt cssUpdaters of 621 | Nothing -> value 622 | Just f -> f value elems 623 | 624 | instance XMLUpdatable Rectangle where 625 | xmlTagName _ = "rect" 626 | serializeTreeNode = genericSerializeWithDrawAttr 627 | attributes = 628 | ["width" `parseIn` rectWidth 629 | ,"height" `parseIn` rectHeight 630 | ,"x" `parseIn` (rectUpperLeftCorner._1) 631 | ,"y" `parseIn` (rectUpperLeftCorner._2) 632 | ,"rx" `parseIn` (rectCornerRadius._1) 633 | ,"ry" `parseIn` (rectCornerRadius._2) 634 | ] 635 | 636 | instance XMLUpdatable Image where 637 | xmlTagName _ = "image" 638 | serializeTreeNode = genericSerializeWithDrawAttr 639 | attributes = 640 | ["width" `parseIn` imageWidth 641 | ,"height" `parseIn` imageHeight 642 | ,"x" `parseIn` (imageCornerUpperLeft._1) 643 | ,"y" `parseIn` (imageCornerUpperLeft._2) 644 | ,parserSetter "href" imageHref (Just . dropSharp) Just 645 | ,"preserveAspectRatio" `parseIn` imageAspectRatio 646 | ] 647 | 648 | instance XMLUpdatable Line where 649 | xmlTagName _ = "line" 650 | serializeTreeNode = genericSerializeWithDrawAttr 651 | attributes = 652 | ["x1" `parseIn` (linePoint1._1) 653 | ,"y1" `parseIn` (linePoint1._2) 654 | ,"x2" `parseIn` (linePoint2._1) 655 | ,"y2" `parseIn` (linePoint2._2) 656 | ] 657 | 658 | instance XMLUpdatable Ellipse where 659 | xmlTagName _ = "ellipse" 660 | serializeTreeNode = genericSerializeWithDrawAttr 661 | attributes = 662 | ["cx" `parseIn` (ellipseCenter._1) 663 | ,"cy" `parseIn` (ellipseCenter._2) 664 | ,"rx" `parseIn` ellipseXRadius 665 | ,"ry" `parseIn` ellipseYRadius 666 | ] 667 | 668 | instance XMLUpdatable Circle where 669 | xmlTagName _ = "circle" 670 | serializeTreeNode = genericSerializeWithDrawAttr 671 | attributes = 672 | ["cx" `parseIn` (circleCenter._1) 673 | ,"cy" `parseIn` (circleCenter._2) 674 | ,"r" `parseIn` circleRadius 675 | ] 676 | 677 | instance XMLUpdatable Mask where 678 | xmlTagName _ = "mask" 679 | serializeTreeNode node = 680 | updateWithAccessor _maskContent node $ 681 | genericSerializeWithDrawAttr node 682 | 683 | attributes = 684 | ["x" `parseIn` (maskPosition._1) 685 | ,"y" `parseIn` (maskPosition._2) 686 | ,"width" `parseIn` maskWidth 687 | ,"height" `parseIn` maskHeight 688 | ,"maskContentUnits" `parseIn` maskContentUnits 689 | ,"maskUnits" `parseIn` maskUnits 690 | ] 691 | 692 | instance XMLUpdatable ClipPath where 693 | xmlTagName _ = "clipPath" 694 | serializeTreeNode node = 695 | updateWithAccessor _clipPathContent node $ 696 | genericSerializeWithDrawAttr node 697 | attributes = 698 | ["clipPathUnits" `parseIn` clipPathUnits] 699 | 700 | instance XMLUpdatable Polygon where 701 | xmlTagName _ = "polygon" 702 | serializeTreeNode = genericSerializeWithDrawAttr 703 | attributes = ["points" `parseIn` polygonPoints] 704 | 705 | instance XMLUpdatable PolyLine where 706 | xmlTagName _ = "polyline" 707 | serializeTreeNode = genericSerializeWithDrawAttr 708 | attributes = ["points" `parseIn` polyLinePoints] 709 | 710 | instance XMLUpdatable Path where 711 | xmlTagName _ = "path" 712 | serializeTreeNode = genericSerializeWithDrawAttr 713 | attributes = ["d" `parseIn` pathDefinition] 714 | 715 | instance XMLUpdatable MeshGradientPatch where 716 | xmlTagName _ = "meshpatch" 717 | attributes = [] 718 | serializeTreeNode node = 719 | updateWithAccessor _meshGradientPatchStops node $ genericSerializeNode node 720 | 721 | instance XMLUpdatable MeshGradientRow where 722 | xmlTagName _ = "meshrow" 723 | serializeTreeNode node = 724 | updateWithAccessor _meshGradientRowPatches node $ genericSerializeNode node 725 | attributes = [] 726 | 727 | instance XMLUpdatable MeshGradient where 728 | xmlTagName _ = "meshgradient" 729 | serializeTreeNode node = 730 | updateWithAccessor _meshGradientRows node $ genericSerializeWithDrawAttr node 731 | attributes = 732 | ["x" `parseIn` meshGradientX 733 | ,"y" `parseIn` meshGradientY 734 | ,"type" `parseIn` meshGradientType 735 | ,"gradientUnits" `parseIn` meshGradientUnits 736 | ,"gradientTransform" `parseIn` meshGradientTransform 737 | ] 738 | 739 | 740 | instance XMLUpdatable LinearGradient where 741 | xmlTagName _ = "linearGradient" 742 | serializeTreeNode node = 743 | updateWithAccessor _linearGradientStops node $ genericSerializeNode node 744 | 745 | attributes = 746 | ["gradientTransform" `parseIn` linearGradientTransform 747 | ,"gradientUnits" `parseIn` linearGradientUnits 748 | ,"spreadMethod" `parseIn` linearGradientSpread 749 | ,"x1" `parseIn` (linearGradientStart._1) 750 | ,"y1" `parseIn` (linearGradientStart._2) 751 | ,"x2" `parseIn` (linearGradientStop._1) 752 | ,"y2" `parseIn` (linearGradientStop._2) 753 | ] 754 | 755 | instance XMLUpdatable Tree where 756 | xmlTagName _ = "TREE" 757 | attributes = [] 758 | serializeTreeNode e = case e of 759 | None -> Nothing 760 | UseTree u _ -> serializeTreeNode u 761 | GroupTree g -> serializeTreeNode g 762 | SymbolTree s -> serializeTreeNode s 763 | PathTree p -> serializeTreeNode p 764 | CircleTree c -> serializeTreeNode c 765 | PolyLineTree p -> serializeTreeNode p 766 | PolygonTree p -> serializeTreeNode p 767 | EllipseTree el -> serializeTreeNode el 768 | LineTree l -> serializeTreeNode l 769 | RectangleTree r -> serializeTreeNode r 770 | TextTree Nothing t -> serializeTreeNode t 771 | ImageTree i -> serializeTreeNode i 772 | MeshGradientTree m -> serializeTreeNode m 773 | TextTree (Just p) t -> do 774 | textNode <- serializeTreeNode t 775 | pathNode <- serializeTreeNode p 776 | let sub = [X.Elem . setChildren pathNode $ X.elContent textNode] 777 | return $ setChildren textNode sub 778 | 779 | 780 | isNotNone :: Tree -> Bool 781 | isNotNone None = False 782 | isNotNone _ = True 783 | 784 | instance XMLUpdatable (Group Tree) where 785 | xmlTagName _ = "g" 786 | serializeTreeNode node = 787 | updateWithAccessor (filter isNotNone . _groupChildren) node $ 788 | genericSerializeWithDrawAttr node 789 | attributes = [] 790 | 791 | instance XMLUpdatable (Symbol Tree) where 792 | xmlTagName _ = "symbol" 793 | serializeTreeNode node = 794 | updateWithAccessor (filter isNotNone . _groupChildren . _groupOfSymbol) node $ 795 | genericSerializeWithDrawAttr node 796 | attributes = 797 | ["viewBox" `parseIn` (groupOfSymbol . groupViewBox) 798 | ,"preserveAspectRatio" `parseIn` (groupOfSymbol . groupAspectRatio) 799 | ] 800 | 801 | 802 | instance XMLUpdatable RadialGradient where 803 | xmlTagName _ = "radialGradient" 804 | serializeTreeNode node = 805 | updateWithAccessor _radialGradientStops node $ genericSerializeNode node 806 | attributes = 807 | ["gradientTransform" `parseIn` radialGradientTransform 808 | ,"gradientUnits" `parseIn` radialGradientUnits 809 | ,"spreadMethod" `parseIn` radialGradientSpread 810 | ,"cx" `parseIn` (radialGradientCenter._1) 811 | ,"cy" `parseIn` (radialGradientCenter._2) 812 | ,"r" `parseIn` radialGradientRadius 813 | ,"fx" `parseIn` radialGradientFocusX 814 | ,"fy" `parseIn` radialGradientFocusY 815 | ] 816 | 817 | instance XMLUpdatable Use where 818 | xmlTagName _ = "use" 819 | serializeTreeNode = genericSerializeWithDrawAttr 820 | attributes = 821 | ["x" `parseIn` (useBase._1) 822 | ,"y" `parseIn` (useBase._2) 823 | ,"width" `parseIn` useWidth 824 | ,"height" `parseIn` useHeight 825 | ,parserSetter "href" useName (Just . dropSharp) (Just . ('#':)) 826 | ] 827 | 828 | dropSharp :: String -> String 829 | dropSharp ('#':rest) = rest 830 | dropSharp a = a 831 | 832 | instance XMLUpdatable TextInfo where 833 | xmlTagName _ = "tspan" 834 | serializeTreeNode = genericSerializeNode 835 | attributes = 836 | [parserSetter "x" textInfoX (parse dashArray) dashNotEmpty 837 | ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty 838 | ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty 839 | ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty 840 | ,parserSetter "rotate" textInfoRotate 841 | (parse numberList) 842 | rotateNotEmpty 843 | ,"textLength" `parseIn` textInfoLength 844 | ] 845 | where 846 | dashNotEmpty [] = Nothing 847 | dashNotEmpty lst = Just $ serializeDashArray lst 848 | 849 | rotateNotEmpty [] = Nothing 850 | rotateNotEmpty lst = 851 | Just . unwords $ printf "%g" <$> lst 852 | 853 | 854 | instance XMLUpdatable TextPath where 855 | xmlTagName _ = "textPath" 856 | serializeTreeNode = genericSerializeNode 857 | attributes = 858 | ["startOffset" `parseIn` textPathStartOffset 859 | ,"method" `parseIn` textPathMethod 860 | ,"spacing" `parseIn` textPathSpacing 861 | ,parserSetter "href" textPathName (Just . dropSharp) (Just . ('#':)) 862 | ] 863 | 864 | instance XMLUpdatable Text where 865 | xmlTagName _ = "text" 866 | serializeTreeNode = serializeText 867 | attributes = ["lengthAdjust" `parseIn` textAdjust] 868 | 869 | 870 | instance XMLUpdatable Pattern where 871 | xmlTagName _ = "pattern" 872 | serializeTreeNode node = 873 | updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node 874 | attributes = 875 | ["viewBox" `parseIn` patternViewBox 876 | ,"patternUnits" `parseIn` patternUnit 877 | ,"width" `parseIn` patternWidth 878 | ,"height" `parseIn` patternHeight 879 | ,"x" `parseIn` (patternPos._1) 880 | ,"y" `parseIn` (patternPos._2) 881 | ,"preserveAspectRatio" `parseIn` patternAspectRatio 882 | ,parserSetter "href" patternHref (Just . dropSharp) (Just . ('#':)) 883 | ,"patternTransform" `parseIn` patternTransform 884 | ] 885 | 886 | instance XMLUpdatable Marker where 887 | xmlTagName _ = "marker" 888 | serializeTreeNode node = 889 | updateWithAccessor _markerElements node $ genericSerializeWithDrawAttr node 890 | attributes = 891 | ["refX" `parseIn` (markerRefPoint._1) 892 | ,"refY" `parseIn` (markerRefPoint._2) 893 | ,"markerWidth" `parseIn` markerWidth 894 | ,"markerHeight" `parseIn` markerHeight 895 | ,"patternUnits" `parseIn` markerUnits 896 | ,"orient" `parseIn` markerOrient 897 | ,"viewBox" `parseIn` markerViewBox 898 | ,"overflow" `parseIn` markerOverflow 899 | ,"preserveAspectRatio" `parseIn` markerAspectRatio 900 | ] 901 | 902 | serializeText :: Text -> Maybe X.Element 903 | serializeText topText = namedNode where 904 | namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode 905 | topNode = serializeSpan $ _textRoot topText 906 | 907 | serializeSpan tspan = case (info, drawInfo) of 908 | (Nothing, Nothing) -> Nothing 909 | (Just a, Nothing) -> Just $ setChildren a subContent 910 | (Nothing, Just b) -> Just $ setChildren b subContent 911 | (Just a, Just b) -> 912 | Just $ setChildren (mergeAttributes a b) subContent 913 | where 914 | info = genericSerializeNode $ _spanInfo tspan 915 | drawInfo = genericSerializeNode $ _spanDrawAttributes tspan 916 | subContent = catMaybes $ serializeContent <$> _spanContent tspan 917 | 918 | serializeContent (SpanText t) = Just . X.Text $ X.blank_cdata { X.cdData = T.unpack t } 919 | serializeContent (SpanTextRef _t) = Just . X.Text $ X.blank_cdata { X.cdData = "" } 920 | serializeContent (SpanSub sub) = X.Elem <$> serializeSpan sub 921 | 922 | unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath) 923 | unparseText = extractResult . go True 924 | where 925 | extractResult (a, b, _) = (a, b) 926 | 927 | go startStrip [] = ([], Nothing, startStrip) 928 | go startStrip (X.CRef _:rest) = go startStrip rest 929 | go startStrip (X.Elem e@(nodeName -> "tspan"):rest) = 930 | (SpanSub spans : trest, mpath, retStrip) 931 | where 932 | (trest, mpath, retStrip) = go restStrip rest 933 | (sub, _, restStrip) = go startStrip $ X.elContent e 934 | spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub 935 | 936 | go startStrip (X.Elem e@(nodeName -> "tref"):rest) = 937 | case attributeFinder "href" e of 938 | Nothing -> go startStrip rest 939 | Just v -> (SpanTextRef v : trest, mpath, stripRet) 940 | where (trest, mpath, stripRet) = go startStrip rest 941 | 942 | go startStrip (X.Elem e@(nodeName -> "textPath"):rest) = 943 | case attributeFinder "href" e of 944 | Nothing -> go startStrip rest 945 | Just v -> (tsub ++ trest, pure p, retStrp) 946 | where 947 | p = (xmlUnparse e) { _textPathName = dropSharp v } 948 | (trest, _, retStrp) = go restStrip rest 949 | (tsub, _, restStrip) = go startStrip $ X.elContent e 950 | 951 | go startStrip (X.Elem _:rest) = go startStrip rest 952 | go startStrip (X.Text t:rest) 953 | | T.length cleanText == 0 = go startStrip rest 954 | | otherwise = 955 | (SpanText cleanText : trest, mpath, stripRet) 956 | where 957 | (trest, mpath, stripRet) = go subShouldStrip rest 958 | 959 | subShouldStrip = T.pack " " `T.isSuffixOf` cleanText 960 | 961 | space = T.singleton ' ' 962 | singulariseSpaces tt 963 | | space `T.isPrefixOf` tt = space 964 | | otherwise = tt 965 | 966 | stripStart | startStrip = T.stripStart 967 | | otherwise = id 968 | 969 | cleanText = stripStart 970 | . T.concat 971 | . fmap singulariseSpaces 972 | . T.groupBy (\a b -> (a /= ' ' && b /= ' ') || a == b) 973 | . T.filter (\c -> c /= '\n' && c /= '\r') 974 | . T.map (\c -> if c == '\t' then ' ' else c) 975 | . T.pack 976 | $ X.cdData t 977 | 978 | gradientOffsetSetter :: SvgAttributeLens GradientStop 979 | gradientOffsetSetter = SvgAttributeLens "offset" setter serialize 980 | where 981 | serialize a = Just $ printf "%d%%" percentage 982 | where percentage = floor . (100 *) $ a ^. gradientOffset :: Int 983 | 984 | setter el str = el & gradientOffset .~ val 985 | where 986 | val = realToFrac $ case parseMayStartDot complexNumber str of 987 | Nothing -> 0 988 | Just (Num n) -> n 989 | Just (Px n) -> n 990 | Just (Percent n) -> n 991 | Just (Em n) -> n 992 | Just (Pc n) -> n 993 | Just (Mm n) -> n 994 | Just (Cm n) -> n 995 | Just (Point n) -> n 996 | Just (Inches n) -> n 997 | 998 | instance XMLUpdatable GradientStop where 999 | xmlTagName _ = "stop" 1000 | serializeTreeNode = genericSerializeNode 1001 | attributes = styleAttribute cssAvailable : fmap fst cssAvailable ++ lst where 1002 | cssAvailable :: [(SvgAttributeLens GradientStop, CssUpdater GradientStop)] 1003 | cssAvailable = 1004 | [(opacitySetter "stop-opacity" gradientOpacity, (cssUniqueFloat gradientOpacity)) 1005 | ,("stop-color" `parseIn` gradientColor, cssUniqueColor gradientColor) 1006 | ] 1007 | 1008 | lst = 1009 | [gradientOffsetSetter 1010 | ,"path" `parseIn` gradientPath 1011 | ] 1012 | 1013 | 1014 | data Symbols = Symbols 1015 | { symbols :: !(M.Map String Element) 1016 | , cssStyle :: [CssRule] 1017 | } 1018 | 1019 | emptyState :: Symbols 1020 | emptyState = Symbols mempty mempty 1021 | 1022 | parseGradientStops :: X.Element -> [GradientStop] 1023 | parseGradientStops = concatMap unStop . elChildren 1024 | where 1025 | unStop e@(nodeName -> "stop") = [xmlUnparse e] 1026 | unStop _ = [] 1027 | 1028 | parseMeshGradientPatches :: X.Element -> [MeshGradientPatch] 1029 | parseMeshGradientPatches = foldMap unparsePatch . elChildren where 1030 | unparsePatch e@(nodeName -> "meshpatch") = [MeshGradientPatch $ parseGradientStops e] 1031 | unparsePatch _ = [] 1032 | 1033 | parseMeshGradientRows :: X.Element -> [MeshGradientRow] 1034 | parseMeshGradientRows = foldMap unRows . elChildren where 1035 | unRows e@(nodeName -> "meshrow") = [MeshGradientRow $ parseMeshGradientPatches e] 1036 | unRows _ = [] 1037 | 1038 | withId :: X.Element -> (X.Element -> Element) 1039 | -> State Symbols Tree 1040 | withId el f = case attributeFinder "id" el of 1041 | Nothing -> return None 1042 | Just elemId -> do 1043 | modify $ \s -> 1044 | s { symbols = M.insert elemId (f el) $ symbols s } 1045 | return None 1046 | 1047 | isDefTag :: String -> Bool 1048 | isDefTag n = n `elem` defList where 1049 | defList = 1050 | [ "pattern" 1051 | , "marker" 1052 | , "mask" 1053 | , "clipPath" 1054 | , "linearGradient" 1055 | , "meshgradient" 1056 | , "radialGradient"] 1057 | 1058 | unparseDefs :: X.Element -> State Symbols Tree 1059 | unparseDefs e@(nodeName -> "pattern") = do 1060 | subElements <- mapM unparse $ elChildren e 1061 | withId e . const . ElementPattern $ pat { _patternElements = subElements} 1062 | where 1063 | pat = xmlUnparse e 1064 | unparseDefs e@(nodeName -> "marker") = do 1065 | subElements <- mapM unparse $ elChildren e 1066 | withId e . const . ElementMarker $ mark {_markerElements = subElements } 1067 | where 1068 | mark = xmlUnparseWithDrawAttr e 1069 | unparseDefs e@(nodeName -> "mask") = do 1070 | children <- mapM unparse $ elChildren e 1071 | let realChildren = filter isNotNone children 1072 | parsedMask = xmlUnparseWithDrawAttr e 1073 | withId e . const . ElementMask $ parsedMask { _maskContent = realChildren } 1074 | 1075 | unparseDefs e@(nodeName -> "clipPath") = do 1076 | children <- mapM unparse $ elChildren e 1077 | let realChildren = filter isNotNone children 1078 | parsedClip = xmlUnparseWithDrawAttr e 1079 | withId e . const . ElementClipPath $ parsedClip { _clipPathContent = realChildren } 1080 | 1081 | unparseDefs e@(nodeName -> "linearGradient") = 1082 | withId e $ ElementLinearGradient . unparser 1083 | where 1084 | unparser ee = 1085 | xmlUnparse ee & linearGradientStops .~ parseGradientStops ee 1086 | 1087 | unparseDefs e@(nodeName -> "meshgradient") = 1088 | withId e $ ElementMeshGradient . unparser 1089 | where 1090 | unparser ee = 1091 | xmlUnparseWithDrawAttr ee & meshGradientRows .~ parseMeshGradientRows ee 1092 | 1093 | unparseDefs e@(nodeName -> "radialGradient") = 1094 | withId e $ ElementRadialGradient . unparser 1095 | where 1096 | unparser ee = 1097 | xmlUnparse ee & radialGradientStops .~ parseGradientStops ee 1098 | unparseDefs e = do 1099 | el <- unparse e 1100 | withId e (const $ ElementGeometry el) 1101 | 1102 | unparse :: X.Element -> State Symbols Tree 1103 | unparse e@(nodeName -> "style") = do 1104 | case parseOnly (many1 ruleSet) . T.pack $ strContent e of 1105 | Left _ -> return () 1106 | Right rules -> 1107 | modify $ \s -> s { cssStyle = cssStyle s ++ rules } 1108 | return None 1109 | unparse e@(nodeName -> "defs") = do 1110 | mapM_ unparseDefs $ elChildren e 1111 | return None 1112 | unparse e@(nodeName -> "symbol") = do 1113 | symbolChildren <- mapM unparse $ elChildren e 1114 | let realChildren = filter isNotNone symbolChildren 1115 | pure . SymbolTree . Symbol $ groupNode & groupChildren .~ realChildren 1116 | where 1117 | groupNode :: Group Tree 1118 | groupNode = _groupOfSymbol $ xmlUnparseWithDrawAttr e 1119 | 1120 | unparse e@(nodeName -> "g") = do 1121 | children <- mapM unparse $ elChildren e 1122 | let realChildren = filter isNotNone children 1123 | 1124 | groupNode :: Group Tree 1125 | groupNode = xmlUnparseWithDrawAttr e 1126 | 1127 | pure $ GroupTree $ groupNode & groupChildren .~ realChildren 1128 | 1129 | unparse e@(nodeName -> "text") = do 1130 | pathWithGeometry <- pathGeomtryOf tPath 1131 | pure . TextTree pathWithGeometry $ xmlUnparse e & textRoot .~ root 1132 | where 1133 | (textContent, tPath) = unparseText $ X.elContent e 1134 | 1135 | pathGeomtryOf Nothing = pure Nothing 1136 | pathGeomtryOf (Just pathInfo) = do 1137 | pathElem <- gets $ M.lookup (_textPathName pathInfo) . symbols 1138 | case pathElem of 1139 | Nothing -> pure Nothing 1140 | Just (ElementLinearGradient _) -> pure Nothing 1141 | Just (ElementRadialGradient _) -> pure Nothing 1142 | Just (ElementMeshGradient _) -> pure Nothing 1143 | Just (ElementPattern _) -> pure Nothing 1144 | Just (ElementMask _) -> pure Nothing 1145 | Just (ElementClipPath _) -> pure Nothing 1146 | Just (ElementMarker _) -> pure Nothing 1147 | Just (ElementGeometry (PathTree p)) -> 1148 | pure . Just $ pathInfo { _textPathData = _pathDefinition p } 1149 | Just (ElementGeometry _) -> pure Nothing 1150 | 1151 | root = TextSpan 1152 | { _spanInfo = xmlUnparse e 1153 | , _spanDrawAttributes = xmlUnparse e 1154 | , _spanContent = textContent 1155 | } 1156 | 1157 | unparse e = case nodeName e of 1158 | "image" -> pure $ ImageTree parsed 1159 | "ellipse" -> pure $ EllipseTree parsed 1160 | "rect" -> pure $ RectangleTree parsed 1161 | "polyline" -> pure $ PolyLineTree parsed 1162 | "polygon" -> pure $ PolygonTree parsed 1163 | "circle"-> pure $ CircleTree parsed 1164 | "line" -> pure $ LineTree parsed 1165 | "path" -> pure $ PathTree parsed 1166 | "meshgradient" -> 1167 | pure $ MeshGradientTree $ parsed & meshGradientRows .~ parseMeshGradientRows e 1168 | "use" -> pure $ UseTree parsed Nothing 1169 | n | isDefTag n -> unparseDefs e 1170 | _ -> pure None 1171 | where 1172 | parsed :: (XMLUpdatable a, WithDrawAttributes a) => a 1173 | parsed = xmlUnparseWithDrawAttr e 1174 | 1175 | unparseDocument :: FilePath -> X.Element -> Maybe Document 1176 | unparseDocument rootLocation e@(nodeName -> "svg") = Just Document 1177 | { _viewBox = 1178 | attributeFinder "viewBox" e >>= parse viewBoxParser 1179 | , _elements = parsedElements 1180 | , _width = lengthFind "width" 1181 | , _height = lengthFind "height" 1182 | , _definitions = symbols named 1183 | , _description = "" 1184 | , _styleRules = cssStyle named 1185 | , _documentLocation = rootLocation 1186 | } 1187 | where 1188 | (parsedElements, named) = 1189 | runState (mapM unparse $ elChildren e) emptyState 1190 | lengthFind n = 1191 | attributeFinder n e >>= parse complexNumber 1192 | unparseDocument _ _ = Nothing 1193 | 1194 | -- | Transform a SVG document to a XML node. 1195 | xmlOfDocument :: Document -> X.Element 1196 | xmlOfDocument doc = 1197 | X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ defsTag ++ children) 1198 | where 1199 | attr name = X.Attr (X.unqual name) 1200 | children = catMaybes [serializeTreeNode el | el <- _elements doc] 1201 | 1202 | defsTag | null defs = [] 1203 | | otherwise = [X.node (X.unqual "defs") defs] 1204 | 1205 | defs = catMaybes [elementRender k e | (k, e) <- M.assocs $ _definitions doc] 1206 | 1207 | elementRender k e = case e of 1208 | ElementGeometry t -> serialize t 1209 | ElementMarker m -> serialize m 1210 | ElementMask m -> serialize m 1211 | ElementClipPath c -> serialize c 1212 | ElementPattern p -> serialize p 1213 | ElementLinearGradient lg -> addId $ serializeTreeNode lg 1214 | ElementRadialGradient rg -> addId $ serializeTreeNode rg 1215 | ElementMeshGradient mg -> addId $ serializeTreeNode mg 1216 | where 1217 | addId = fmap (X.add_attr $ attr "id" k) 1218 | 1219 | serialize :: (WithDrawAttributes e, XMLUpdatable e) => e -> Maybe X.Element 1220 | serialize el = case el^.drawAttr.attrId of 1221 | Nothing -> addId $ serializeTreeNode el 1222 | Just _id -> 1223 | let newNode = el & drawAttr.attrId .~ Just k in 1224 | serializeTreeNode newNode 1225 | 1226 | docViewBox = case _viewBox doc of 1227 | Nothing -> [] 1228 | Just b -> [attr "viewBox" $ serializeViewBox b] 1229 | 1230 | descTag = case _description doc of 1231 | "" -> [] 1232 | txt -> [X.node (X.unqual "desc") txt] 1233 | 1234 | styleTag = case _styleRules doc of 1235 | [] -> [] 1236 | rules -> [X.node (X.unqual "style") 1237 | ([attr "type" "text/css"], txt)] 1238 | where txt = TL.unpack . TB.toLazyText $ foldMap tserialize rules 1239 | 1240 | attrs = 1241 | docViewBox ++ 1242 | [attr "xmlns" "http://www.w3.org/2000/svg" 1243 | ,attr "xmlns:xlink" "http://www.w3.org/1999/xlink" 1244 | ,attr "version" "1.1"] ++ 1245 | catMaybes [attr "width" . serializeNumber <$> _width doc 1246 | ,attr "height" . serializeNumber <$> _height doc 1247 | ] 1248 | 1249 | -------------------------------------------------------------------------------- /svg-tree.cabal: -------------------------------------------------------------------------------- 1 | name: svg-tree 2 | version: 0.6.2.4 3 | synopsis: SVG file loader and serializer 4 | description: 5 | svg-tree provides types representing a SVG document, 6 | and allows to load and save it. 7 | . 8 | The types definition are aimed at rendering, 9 | so they are rather comple. For simpler SVG document building, 10 | look after `lucid-svg`. 11 | . 12 | To render an svg document you can use the `rasterific-svg` package 13 | 14 | 15 | license: BSD3 16 | author: Vincent Berthoux 17 | maintainer: Vincent Berthoux 18 | -- copyright: 19 | category: Graphics, Svg 20 | build-type: Simple 21 | cabal-version: >=1.10 22 | 23 | extra-source-files: changelog.md 24 | 25 | Source-Repository head 26 | Type: git 27 | Location: git://github.com/Twinside/svg-tree.git 28 | 29 | Source-Repository this 30 | Type: git 31 | Location: git://github.com/Twinside/svg-tree.git 32 | Tag: v0.6.2.4 33 | 34 | library 35 | hs-source-dirs: src 36 | Ghc-options: -O3 -Wall 37 | default-language: Haskell2010 38 | exposed-modules: Graphics.Svg 39 | , Graphics.Svg.CssTypes 40 | , Graphics.Svg.Types 41 | , Graphics.Svg.PathParser 42 | 43 | other-modules: Graphics.Svg.NamedColors 44 | , Graphics.Svg.XmlParser 45 | , Graphics.Svg.CssParser 46 | , Graphics.Svg.ColorParser 47 | 48 | if impl(ghc >= 8.0) 49 | ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances 50 | else 51 | -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 52 | build-depends: fail == 4.9.*, semigroups == 0.18.* 53 | 54 | build-depends: base >= 4.5 && < 6 55 | , JuicyPixels >= 3.2 56 | , attoparsec >= 0.12 57 | , scientific >= 0.3 58 | , containers >= 0.4 59 | , xml >= 1.3 60 | , bytestring >= 0.10 61 | , linear >= 1.20 62 | , vector >= 0.10 63 | , text >= 1.1 64 | , transformers >= 0.3 && < 0.7 65 | , mtl >= 2.1 && < 2.4 66 | , lens >= 4.6 67 | 68 | test-suite test 69 | hs-source-dirs: test 70 | main-is: Spec.hs 71 | type: exitcode-stdio-1.0 72 | build-depends: base 73 | , svg-tree 74 | , attoparsec >= 0.12 75 | , scientific >= 0.3 76 | , linear >= 1.20 77 | , hspec 78 | ghc-options: -Wall -threaded 79 | other-modules: PathParserSpec 80 | -------------------------------------------------------------------------------- /test/PathParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module PathParserSpec where 3 | 4 | import Data.Attoparsec.Text 5 | import Graphics.Svg.PathParser 6 | import Graphics.Svg.Types 7 | import Linear 8 | import Test.Hspec 9 | 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "num" $ do 14 | it "support shorthand number" $ do 15 | parseOnly command d `shouldBe` Right p 16 | where 17 | d = "M-.10 .10z" 18 | p = MoveTo OriginAbsolute [V2 (-0.1) 0.10] 19 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------