svg-tree 0.2 → 0.3
raw patch · 9 files changed
+356/−351 lines, 9 files
Files
- changelog +4/−0
- src/Graphics/Svg.hs +2/−2
- src/Graphics/Svg/ColorParser.hs +2/−2
- src/Graphics/Svg/CssParser.hs +7/−7
- src/Graphics/Svg/CssTypes.hs +271/−271
- src/Graphics/Svg/PathParser.hs +15/−15
- src/Graphics/Svg/Types.hs +20/−20
- src/Graphics/Svg/XmlParser.hs +32/−31
- svg-tree.cabal +3/−3
changelog view
@@ -1,5 +1,9 @@ -*-change-log-*- +v0.3 April 2015+ * Breaking change: Switching all the numeric types associated to geometry+ to Double precision (thx to Kasbah)+ v0.2 April 2015 * Fix: Differentiating opacity & fill-opacity, as they are semantically deferent (BREAKING CHANGE!)
src/Graphics/Svg.hs view
@@ -56,8 +56,8 @@ writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument cssDeclApplyer :: DrawAttributes -> CssDeclaration- -> DrawAttributes -cssDeclApplyer value (CssDeclaration txt elems) = + -> DrawAttributes+cssDeclApplyer value (CssDeclaration txt elems) = case lookup txt cssUpdaters of Nothing -> value Just f -> f value elems
src/Graphics/Svg/ColorParser.hs view
@@ -43,7 +43,7 @@ num :: Parser Double num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)- where doubleNumber :: Parser Float+ where doubleNumber :: Parser Double doubleNumber = toRealFloat <$> scientific plusMinus = negate <$ string "-" <*> doubleNumber@@ -70,7 +70,7 @@ namedColor = do str <- takeWhile1 (inClass "a-z") return $ M.findWithDefault black str svgNamedColors- + percentToWord v = floor $ v * (255 / 100) numPercent = ((percentToWord <$> num) <* string "%")
src/Graphics/Svg/CssParser.hs view
@@ -58,7 +58,7 @@ {-import Graphics.Rasterific.Linear( V2( V2 ) )-} {-import Graphics.Rasterific.Transformations-} -num :: Parser Float+num :: Parser Double num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace) where doubleNumber = char '.' *> (scale <$> double) <|> double@@ -171,7 +171,7 @@ declaration :: Parser CssDeclaration declaration = CssDeclaration <$> property- <*> (char ':' + <*> (char ':' *> cleanSpace *> many1 expr <* prio@@ -185,7 +185,7 @@ operator = skipSpace *> op <* skipSpace where op = CssOpSlash <$ char '/'- <|> CssOpComa <$ char ',' + <|> CssOpComa <$ char ',' <?> "operator" expr :: Parser [CssElement]@@ -198,7 +198,7 @@ dashArray :: Parser [Number] dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp) -numberList :: Parser [Float]+numberList :: Parser [Double] numberList = skipSpace *> (num `sepBy1` commaWsp) complexNumber :: Parser Number@@ -222,7 +222,7 @@ <|> (CssColor <$> colorParser) where comma = skipSpace *> char ',' <* skipSpace- checkNamedColor n + checkNamedColor n | Just c <- M.lookup n svgNamedColors = CssColor c | otherwise = CssIdent n @@ -232,8 +232,8 @@ [CssNumber r, CssNumber g, CssNumber b]) = CssColor $ PixelRGBA8 (to r) (to g) (to b) 255 where clamp = max 0 . min 255- to (Num n) = floor $ clamp n - to (Px n) = floor $ clamp n + to (Num n) = floor $ clamp n+ to (Px n) = floor $ clamp n to (Percent p) = floor . clamp $ p * 255 to (Em c) = floor $ clamp c to (Pc n) = floor $ clamp n
src/Graphics/Svg/CssTypes.hs view
@@ -1,271 +1,271 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} --- | Define the types used to describes CSS elements -module Graphics.Svg.CssTypes - ( CssSelector( .. ) - , CssSelectorRule - , CssRule( .. ) - , CssDescriptor( .. ) - , CssDeclaration( .. ) - , CssElement( .. ) - - , CssMatcheable( .. ) - , CssContext - , Dpi - , Number( .. ) - , serializeNumber - , findMatchingDeclarations - , toUserUnit - , mapNumber - , tserialize - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mconcat ) -#endif - -import Data.Monoid( (<>) ) -import Data.List( intersperse ) -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as TB -import Text.Printf - -import Codec.Picture( PixelRGBA8( .. ) ) -{-import Debug.Trace-} - --- | Alias describing a "dot per inch" information --- used for size calculation (see toUserUnit). -type Dpi = Int - --- | Helper typeclass for serialization to Text. -class TextBuildable a where - -- | Serialize an element to a text builder. - tserialize :: a -> TB.Builder - --- | Describe an element of a CSS selector. Multiple --- elements can be combined in a CssSelector type. -data CssDescriptor - = OfClass T.Text -- ^ .IDENT - | OfName T.Text -- ^ IDENT - | OfId T.Text -- ^ #IDENT - | OfPseudoClass T.Text -- ^ `:IDENT` (ignore function syntax) - | AnyElem -- ^ '*' - | WithAttrib T.Text T.Text -- ^ `` - deriving (Eq, Show) - -instance TextBuildable CssDescriptor where - tserialize d = case d of - OfClass c -> si '.' <> ft c - OfName n -> ft n - OfId i -> si '#' <> ft i - OfPseudoClass c -> si '#' <> ft c - AnyElem -> si '*' - WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']'] - where - ft = TB.fromText - si = TB.singleton - --- | Define complex selector. -data CssSelector - = Nearby -- ^ Correspond to the `+` CSS selector. - | DirectChildren -- ^ Correspond to the `>` CSS selectro. - | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements - -- of the list must be matched. - deriving (Eq, Show) - -instance TextBuildable CssSelector where - tserialize s = case s of - Nearby -> si '+' - DirectChildren -> si '>' - AllOf lst -> - mconcat . intersperse (si ' ') $ map tserialize lst - where - si = TB.singleton - --- | A CssSelectorRule is a list of all the elements --- that must be meet in a depth first search fashion. -type CssSelectorRule = [CssSelector] - --- | Represent a CSS selector and the different declarations --- to apply to the matched elemens. -data CssRule = CssRule - { -- | At the first level represent a list of elements - -- to be matched. If any match is made, you can apply - -- the declarations. At the second level - cssRuleSelector :: ![CssSelectorRule] - -- | Declarations to apply to the matched element. - , cssDeclarations :: ![CssDeclaration] - } - deriving (Eq, Show) - -instance TextBuildable CssRule where - tserialize (CssRule selectors decl) = - mconcat tselectors - <> ft " {\n" - <> mconcat (fmap tserializeDecl decl) - <> ft "}\n" - where - ft = TB.fromText - tserializeDecl d = ft " " <> tserialize d <> ft ";\n" - tselectors = - intersperse (ft ",\n") . fmap tserialize $ concat selectors - --- | Interface for elements to be matched against --- some CssRule. -class CssMatcheable a where - -- | For an element, tell its optional ID attribute. - cssIdOf :: a -> Maybe T.Text - -- | For an element, return all of it's class attributes. - cssClassOf :: a -> [T.Text] - -- | Return the name of the tagname of the element - cssNameOf :: a -> T.Text - -- | Return a value of a given attribute if present - cssAttribOf :: a -> T.Text -> Maybe T.Text - --- | Represent a zipper in depth at the first list --- level, and the previous nodes at in the second --- list level. -type CssContext a = [[a]] - -isDescribedBy :: CssMatcheable a - => a -> [CssDescriptor] -> Bool -isDescribedBy e = all tryMatch - where - tryMatch (OfClass t) = t `elem` cssClassOf e - tryMatch (OfId i) = cssIdOf e == Just i - tryMatch (OfName n) = cssNameOf e == n - tryMatch (OfPseudoClass _) = False - tryMatch (WithAttrib a v) = cssAttribOf e a == Just v - tryMatch AnyElem = True - -isMatching :: CssMatcheable a - => CssContext a -> [CssSelector] -> Bool -isMatching = go where - go _ [] = True - go [] _ = False - go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest - go ((e:_):upper) (DirectChildren:AllOf descr:rest) - | isDescribedBy e descr = go upper rest - go _ (DirectChildren:_) = False - go ((e:_):upper) (AllOf descr : rest) - | isDescribedBy e descr = go upper rest - | otherwise = False - go (_:upper) selector = go upper selector - --- | Given CSS rules, find all the declaration to apply to the --- element in a given context. -findMatchingDeclarations :: CssMatcheable a - => [CssRule] -> CssContext a -> [CssDeclaration] -findMatchingDeclarations rules context = - concat [cssDeclarations rule - | rule <- rules - , selector <- cssRuleSelector rule - , isMatching context $ reverse selector ] - --- | Represent the content to apply to some --- CSS matched rules. -data CssDeclaration = CssDeclaration - { -- | Property name to change (like font-family or color). - _cssDeclarationProperty :: T.Text - -- | List of values - , _cssDecarationlValues :: [[CssElement]] - } - deriving (Eq, Show) - -instance TextBuildable CssDeclaration where - tserialize (CssDeclaration n elems) = - mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems - where - finalElems = map tserialize (concat elems) - ft = TB.fromText - si = TB.singleton - - --- | Encode complex number possibly dependant to the current --- render size. -data Number - = Num Float -- ^ Simple coordinate in current user coordinate. - | Px Float -- ^ With suffix "px" - | Em Float -- ^ Number relative to the current font size. - | Percent Float -- ^ Number relative to the current viewport size. - | Pc Float - | Mm Float -- ^ Number in millimeters, relative to DPI. - | Cm Float -- ^ Number in centimeters, relative to DPI. - | Point Float -- ^ Number in points, relative to DPI. - | Inches Float -- ^ Number in inches, relative to DPI. - deriving (Eq, Show) - --- | Helper function to modify inner value of a number -mapNumber :: (Float -> Float) -> Number -> Number -mapNumber f nu = case nu of - Num n -> Num $ f n - Px n -> Px $ f n - Em n -> Em $ f n - Percent n -> Percent $ f n - Pc n -> Pc $ f n - Mm n -> Mm $ f n - Cm n -> Cm $ f n - Point n -> Point $ f n - Inches n -> Inches $ f n - --- | Encode the number to string which can be used in a --- CSS or a svg attributes. -serializeNumber :: Number -> String -serializeNumber n = case n of - Num c -> printf "%g" c - Px c -> printf "%gpx" c - Em cc -> printf "%gem" cc - Percent p -> printf "%d%%" (floor $ 100 * p :: Int) - Pc p -> printf "%gpc" p - Mm m -> printf "%gmm" m - Cm c -> printf "%gcm" c - Point p -> printf "%gpt" p - Inches i -> printf "%gin" i - -instance TextBuildable Number where - tserialize = TB.fromText . T.pack . serializeNumber - --- | Value of a CSS property. -data CssElement - = CssIdent !T.Text - | CssString !T.Text - | CssReference !T.Text - | CssNumber !Number - | CssColor !PixelRGBA8 - | CssFunction !T.Text ![CssElement] - | CssOpComa - | CssOpSlash - deriving (Eq, Show) - -instance TextBuildable CssElement where - tserialize e = case e of - CssIdent n -> ft n - CssString s -> si '"' <> ft s <> si '"' - CssReference r -> si '#' <> ft r - CssNumber n -> tserialize n - CssColor (PixelRGBA8 r g b _) -> - ft . T.pack $ printf "#%02X%02X%02X" r g b - CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')'] - where args = intersperse (ft ", ") (map tserialize els) - CssOpComa -> si ',' - CssOpSlash -> si '/' - where - ft = TB.fromText - si = TB.singleton - --- | This function replace all device dependant units to user --- units given it's DPI configuration. --- Preserve percentage and "em" notation. -toUserUnit :: Dpi -> Number -> Number -toUserUnit dpi = go where - go nu = case nu of - Num _ -> nu - Px p -> go $ Num p - Em _ -> nu - Percent _ -> nu - Pc n -> go . Inches $ (12 * n) / 72 - Inches n -> Num $ n * fromIntegral dpi - Mm n -> go . Inches $ n / 25.4 - Cm n -> go . Inches $ n / 2.54 - Point n -> go . Inches $ n / 72 - +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+-- | Define the types used to describes CSS elements+module Graphics.Svg.CssTypes+ ( CssSelector( .. )+ , CssSelectorRule+ , CssRule( .. )+ , CssDescriptor( .. )+ , CssDeclaration( .. )+ , CssElement( .. )++ , CssMatcheable( .. )+ , CssContext+ , Dpi+ , Number( .. )+ , serializeNumber+ , findMatchingDeclarations+ , toUserUnit+ , mapNumber+ , tserialize+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mconcat )+#endif++import Data.Monoid( (<>) )+import Data.List( intersperse )+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TB+import Text.Printf++import Codec.Picture( PixelRGBA8( .. ) )+{-import Debug.Trace-}++-- | Alias describing a "dot per inch" information+-- used for size calculation (see toUserUnit).+type Dpi = Int++-- | Helper typeclass for serialization to Text.+class TextBuildable a where+ -- | Serialize an element to a text builder.+ tserialize :: a -> TB.Builder++-- | Describe an element of a CSS selector. Multiple+-- elements can be combined in a CssSelector type.+data CssDescriptor+ = OfClass T.Text -- ^ .IDENT+ | OfName T.Text -- ^ IDENT+ | OfId T.Text -- ^ #IDENT+ | OfPseudoClass T.Text -- ^ `:IDENT` (ignore function syntax)+ | AnyElem -- ^ '*'+ | WithAttrib T.Text T.Text -- ^ ``+ deriving (Eq, Show)++instance TextBuildable CssDescriptor where+ tserialize d = case d of+ OfClass c -> si '.' <> ft c+ OfName n -> ft n+ OfId i -> si '#' <> ft i+ OfPseudoClass c -> si '#' <> ft c+ AnyElem -> si '*'+ WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']']+ where+ ft = TB.fromText+ si = TB.singleton++-- | Define complex selector.+data CssSelector+ = Nearby -- ^ Correspond to the `+` CSS selector.+ | DirectChildren -- ^ Correspond to the `>` CSS selectro.+ | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements+ -- of the list must be matched.+ deriving (Eq, Show)++instance TextBuildable CssSelector where+ tserialize s = case s of+ Nearby -> si '+'+ DirectChildren -> si '>'+ AllOf lst ->+ mconcat . intersperse (si ' ') $ map tserialize lst+ where+ si = TB.singleton++-- | A CssSelectorRule is a list of all the elements+-- that must be meet in a depth first search fashion.+type CssSelectorRule = [CssSelector]++-- | Represent a CSS selector and the different declarations+-- to apply to the matched elemens.+data CssRule = CssRule+ { -- | At the first level represent a list of elements+ -- to be matched. If any match is made, you can apply+ -- the declarations. At the second level+ cssRuleSelector :: ![CssSelectorRule]+ -- | Declarations to apply to the matched element.+ , cssDeclarations :: ![CssDeclaration]+ }+ deriving (Eq, Show)++instance TextBuildable CssRule where+ tserialize (CssRule selectors decl) =+ mconcat tselectors+ <> ft " {\n"+ <> mconcat (fmap tserializeDecl decl)+ <> ft "}\n"+ where+ ft = TB.fromText+ tserializeDecl d = ft " " <> tserialize d <> ft ";\n"+ tselectors =+ intersperse (ft ",\n") . fmap tserialize $ concat selectors++-- | Interface for elements to be matched against+-- some CssRule.+class CssMatcheable a where+ -- | For an element, tell its optional ID attribute.+ cssIdOf :: a -> Maybe T.Text+ -- | For an element, return all of it's class attributes.+ cssClassOf :: a -> [T.Text]+ -- | Return the name of the tagname of the element+ cssNameOf :: a -> T.Text+ -- | Return a value of a given attribute if present+ cssAttribOf :: a -> T.Text -> Maybe T.Text++-- | Represent a zipper in depth at the first list+-- level, and the previous nodes at in the second+-- list level.+type CssContext a = [[a]]++isDescribedBy :: CssMatcheable a+ => a -> [CssDescriptor] -> Bool+isDescribedBy e = all tryMatch+ where+ tryMatch (OfClass t) = t `elem` cssClassOf e+ tryMatch (OfId i) = cssIdOf e == Just i+ tryMatch (OfName n) = cssNameOf e == n+ tryMatch (OfPseudoClass _) = False+ tryMatch (WithAttrib a v) = cssAttribOf e a == Just v+ tryMatch AnyElem = True++isMatching :: CssMatcheable a+ => CssContext a -> [CssSelector] -> Bool+isMatching = go where+ go _ [] = True+ go [] _ = False+ go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest+ go ((e:_):upper) (DirectChildren:AllOf descr:rest)+ | isDescribedBy e descr = go upper rest+ go _ (DirectChildren:_) = False+ go ((e:_):upper) (AllOf descr : rest)+ | isDescribedBy e descr = go upper rest+ | otherwise = False+ go (_:upper) selector = go upper selector++-- | Given CSS rules, find all the declaration to apply to the+-- element in a given context.+findMatchingDeclarations :: CssMatcheable a+ => [CssRule] -> CssContext a -> [CssDeclaration]+findMatchingDeclarations rules context =+ concat [cssDeclarations rule+ | rule <- rules+ , selector <- cssRuleSelector rule+ , isMatching context $ reverse selector ]++-- | Represent the content to apply to some+-- CSS matched rules.+data CssDeclaration = CssDeclaration+ { -- | Property name to change (like font-family or color).+ _cssDeclarationProperty :: T.Text+ -- | List of values+ , _cssDecarationlValues :: [[CssElement]]+ }+ deriving (Eq, Show)++instance TextBuildable CssDeclaration where+ tserialize (CssDeclaration n elems) =+ mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems+ where+ finalElems = map tserialize (concat elems)+ ft = TB.fromText+ si = TB.singleton+++-- | Encode complex number possibly dependant to the current+-- render size.+data Number+ = Num Double -- ^ Simple coordinate in current user coordinate.+ | Px Double -- ^ With suffix "px"+ | Em Double -- ^ Number relative to the current font size.+ | Percent Double -- ^ Number relative to the current viewport size.+ | Pc Double+ | Mm Double -- ^ Number in millimeters, relative to DPI.+ | Cm Double -- ^ Number in centimeters, relative to DPI.+ | Point Double -- ^ Number in points, relative to DPI.+ | Inches Double -- ^ Number in inches, relative to DPI.+ deriving (Eq, Show)++-- | Helper function to modify inner value of a number+mapNumber :: (Double -> Double) -> Number -> Number+mapNumber f nu = case nu of+ Num n -> Num $ f n+ Px n -> Px $ f n+ Em n -> Em $ f n+ Percent n -> Percent $ f n+ Pc n -> Pc $ f n+ Mm n -> Mm $ f n+ Cm n -> Cm $ f n+ Point n -> Point $ f n+ Inches n -> Inches $ f n++-- | Encode the number to string which can be used in a+-- CSS or a svg attributes.+serializeNumber :: Number -> String+serializeNumber n = case n of+ Num c -> printf "%g" c+ Px c -> printf "%gpx" c+ Em cc -> printf "%gem" cc+ Percent p -> printf "%d%%" (floor $ 100 * p :: Int)+ Pc p -> printf "%gpc" p+ Mm m -> printf "%gmm" m+ Cm c -> printf "%gcm" c+ Point p -> printf "%gpt" p+ Inches i -> printf "%gin" i++instance TextBuildable Number where+ tserialize = TB.fromText . T.pack . serializeNumber++-- | Value of a CSS property.+data CssElement+ = CssIdent !T.Text+ | CssString !T.Text+ | CssReference !T.Text+ | CssNumber !Number+ | CssColor !PixelRGBA8+ | CssFunction !T.Text ![CssElement]+ | CssOpComa+ | CssOpSlash+ deriving (Eq, Show)++instance TextBuildable CssElement where+ tserialize e = case e of+ CssIdent n -> ft n+ CssString s -> si '"' <> ft s <> si '"'+ CssReference r -> si '#' <> ft r+ CssNumber n -> tserialize n+ CssColor (PixelRGBA8 r g b _) ->+ ft . T.pack $ printf "#%02X%02X%02X" r g b+ CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')']+ where args = intersperse (ft ", ") (map tserialize els)+ CssOpComa -> si ','+ CssOpSlash -> si '/'+ where+ ft = TB.fromText+ si = TB.singleton++-- | This function replace all device dependant units to user+-- units given it's DPI configuration.+-- Preserve percentage and "em" notation.+toUserUnit :: Dpi -> Number -> Number+toUserUnit dpi = go where+ go nu = case nu of+ Num _ -> nu+ Px p -> go $ Num p+ Em _ -> nu+ Percent _ -> nu+ Pc n -> go . Inches $ (12 * n) / 72+ Inches n -> Num $ n * fromIntegral dpi+ Mm n -> go . Inches $ n / 25.4+ Cm n -> go . Inches $ n / 2.54+ Point n -> go . Inches $ n / 72+
src/Graphics/Svg/PathParser.hs view
@@ -32,9 +32,9 @@ import qualified Data.Text as T import Text.Printf( printf ) -num :: Parser Float+num :: Parser Double num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)- where doubleNumber :: Parser Float+ where doubleNumber :: Parser Double doubleNumber = toRealFloat <$> scientific plusMinus = negate <$ string "-" <*> doubleNumber@@ -76,8 +76,8 @@ <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList) <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList) <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList)- <|> (ElipticalArc OriginAbsolute <$ string "A" <*> manyComma elipticalArgs)- <|> (ElipticalArc OriginRelative <$ string "a" <*> manyComma elipticalArgs)+ <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs)+ <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs) <|> (EndPath <$ string "Z") <|> (EndPath <$ string "z") where pointList = point `sepBy1` commaWsp@@ -90,12 +90,12 @@ manyComma a = a `sepBy1` commaWsp numComma = num <* commaWsp- elipticalArgs = (,,,,,) <$> numComma- <*> numComma- <*> numComma- <*> numComma- <*> numComma- <*> point+ ellipticalArgs = (,,,,,) <$> numComma+ <*> numComma+ <*> numComma+ <*> (fmap (==0) numComma)+ <*> (fmap (==0) numComma)+ <*> point serializePoint :: RPoint -> String serializePoint (V2 x y) = printf "%g,%g" x y@@ -142,13 +142,13 @@ QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points- ElipticalArc OriginAbsolute args -> "A" ++ serializeArgs args- ElipticalArc OriginRelative args -> "a" ++ serializeArgs args+ EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args+ EllipticalArc OriginRelative args -> "a" ++ serializeArgs args EndPath -> "Z" where serializeArg (a, b, c, d, e, V2 x y) =- printf "%g %g %g %g %g %g,%g" a b c d e x y- serializeArgs = unwords . fmap serializeArg + printf "%g %g %g %g %g %g,%g" a b c (fromEnum d) (fromEnum e) x y+ serializeArgs = unwords . fmap serializeArg @@ -160,7 +160,7 @@ <|> skewYParser <|> skewXParser -functionParser :: T.Text -> Parser [Float]+functionParser :: T.Text -> Parser [Double] functionParser funcName = string funcName *> skipSpace *> char '(' *> skipSpace
src/Graphics/Svg/Types.hs view
@@ -189,7 +189,7 @@ import Text.Printf -- | Basic coordiante type.-type Coord = Float+type Coord = Double -- | Real Point, fully determined and not -- dependant of the rendering context.@@ -226,7 +226,7 @@ -- | Quadratic bezier, 'T' or 't' command | SmoothQuadraticBezierCurveTo Origin [RPoint] -- | Eliptical arc, 'A' or 'a' command.- | ElipticalArc Origin [(Coord, Coord, Coord, Coord, Coord, RPoint)]+ | EllipticalArc Origin [(Coord, Coord, Coord, Bool, Bool, RPoint)] -- | Close the path, 'Z' or 'z' svg path command. | EndPath deriving (Eq, Show)@@ -235,12 +235,12 @@ toPoint :: Number -> Number -> Point toPoint = (,) --- | Tell if the path command is an ElipticalArc.+-- | Tell if the path command is an EllipticalArc. isPathArc :: PathCommand -> Bool-isPathArc (ElipticalArc _ _) = True+isPathArc (EllipticalArc _ _) = True isPathArc _ = False --- | Tell if a full path contain an ElipticalArc.+-- | Tell if a full path contain an EllipticalArc. isPathWithArc :: Foldable f => f PathCommand -> Bool isPathWithArc = F.any isPathArc @@ -286,16 +286,16 @@ TransformMatrix Coord Coord Coord Coord Coord Coord -- | Translation along a vector- | Translate Float Float+ | Translate Double Double -- | Scaling on both axis or on X axis and Y axis.- | Scale Float (Maybe Float)+ | Scale Double (Maybe Double) -- | Rotation around `(0, 0)` or around an optional -- point.- | Rotate Float (Maybe (Float, Float))+ | Rotate Double (Maybe (Double, Double)) -- | Skew transformation along the X axis.- | SkewX Float+ | SkewX Double -- | Skew transformation along the Y axis.- | SkewY Float+ | SkewY Double -- | Unkown transformation, like identity. | TransformUnknown deriving (Eq, Show)@@ -398,7 +398,7 @@ , _strokeLineJoin :: !(Last LineJoin) -- | Define the distance of the miter join, correspond -- to the `stroke-miterlimit` attritbue.- , _strokeMiterLimit :: !(Last Float)+ , _strokeMiterLimit :: !(Last Double) -- | Define the filling color of the elements. Corresponding -- to the `fill` attribute. , _fillColor :: !(Last Texture)@@ -460,7 +460,7 @@ -- segments. Correspond to the `<polyline>` tag. data PolyLine = PolyLine { -- | drawing attributes of the polyline.- _polyLineDrawAttributes :: DrawAttributes + _polyLineDrawAttributes :: DrawAttributes -- | Geometry definition of the polyline. -- correspond to the `points` attribute@@ -535,7 +535,7 @@ -- | Define a rectangle. Correspond to -- `<rectangle>` svg tag.-data Rectangle = Rectangle +data Rectangle = Rectangle { -- | Rectangle drawing attributes. _rectDrawAttributes :: DrawAttributes -- | Upper left corner of the rectangle, correspond@@ -764,7 +764,7 @@ , _textInfoY :: ![Number] -- ^ `y` attribute. , _textInfoDX :: ![Number] -- ^ `dx` attribute. , _textInfoDY :: ![Number] -- ^ `dy` attribute.- , _textInfoRotate :: ![Float] -- ^ `rotate` attribute.+ , _textInfoRotate :: ![Double] -- ^ `rotate` attribute. , _textInfoLength :: !(Maybe Number) -- ^ `textLength` attribute. } deriving (Eq, Show)@@ -1002,7 +1002,7 @@ zipGroup prev g = g { _groupChildren = updatedChildren } where groupChild = _groupChildren g- updatedChildren = + updatedChildren = [dig (c:prev) child | (child, c) <- zip groupChild $ inits groupChild] @@ -1021,7 +1021,7 @@ RectangleTree _ -> f acc e TextTree _ _ -> f acc e ImageTree _ -> f acc e- GroupTree g -> + GroupTree g -> let subAcc = F.foldl' go acc $ _groupChildren g in f subAcc e SymbolTree s ->@@ -1124,7 +1124,7 @@ -- | Define a color stop for the gradients. Represent -- the `<stop>` SVG tag.-data GradientStop = GradientStop +data GradientStop = GradientStop { -- | Gradient offset between 0 and 1, correspond -- to the `offset` attribute. _gradientOffset :: Float@@ -1138,7 +1138,7 @@ makeClassy ''GradientStop instance WithDefaultSvg GradientStop where- defaultSvg = GradientStop + defaultSvg = GradientStop { _gradientOffset = 0.0 , _gradientColor = PixelRGBA8 0 0 0 255 }@@ -1367,7 +1367,7 @@ dy = fromIntegral . abs $ y2 - y1 documentSize _ Document { _width = Just (Num w) , _height = Just (Num h) } = (floor w, floor h)-documentSize dpi doc@(Document { _width = Just w +documentSize dpi doc@(Document { _width = Just w , _height = Just h }) = documentSize dpi $ doc { _width = Just $ toUserUnit dpi w@@ -1382,7 +1382,7 @@ mayMerge a Nothing = a instance Monoid DrawAttributes where- mempty = DrawAttributes + mempty = DrawAttributes { _strokeWidth = Last Nothing , _strokeColor = Last Nothing , _strokeOpacity = Nothing
src/Graphics/Svg/XmlParser.hs view
@@ -97,7 +97,7 @@ aparse = parse pointData aserialize = Just . serializePoints -instance ParseableAttribute Float where+instance ParseableAttribute Double where aparse = parseMayStartDot num aserialize v = Just $ printf "%g" v @@ -127,12 +127,12 @@ "start" -> Just TextAnchorStart "end" -> Just TextAnchorEnd _ -> Nothing- + aserialize t = Just $ case t of TextAnchorMiddle -> "middle" TextAnchorStart -> "start" TextAnchorEnd -> "end"- + instance ParseableAttribute ElementRef where aparse s = case parseOnly pa $ T.pack s of Left _ -> Nothing@@ -194,7 +194,7 @@ "spacing" -> TextAdjustSpacing "spacingAndGlyphs" -> TextAdjustSpacingAndGlyphs _ -> TextAdjustSpacing- + aserialize a = Just $ case a of TextAdjustSpacing -> "spacing" TextAdjustSpacingAndGlyphs -> "spacingAndGlyphs"@@ -298,7 +298,7 @@ , X.attrVal = str } where- xName "href" = + xName "href" = X.QName { X.qName = "href" , X.qURI = Nothing , X.qPrefix = Just "xlink" }@@ -325,7 +325,7 @@ serializer a = printf "%g" <$> a ^. elLens updater el str = case parseMayStartDot num str of Nothing -> el- Just v -> el & elLens .~ Just v+ Just v -> el & elLens .~ Just (realToFrac v) type Serializer e = e -> Maybe String @@ -349,7 +349,7 @@ Nothing -> el Just v -> el & elLens .~ v - serializer a + serializer a | v /= defaultVal = aserialize v | otherwise = Nothing where@@ -365,15 +365,15 @@ Nothing -> el Just v -> el & elLens .~ Last (Just v) - serializer a = getLast (a ^. elLens) >>= serialize + serializer a = getLast (a ^. elLens) >>= serialize classSetter :: SvgAttributeLens DrawAttributes classSetter = SvgAttributeLens "class" updater serializer where- updater el str = + updater el str = el & attrClass .~ (T.split (== ' ') $ T.pack str) - serializer a = + serializer a = Just . T.unpack . T.intercalate " " $ a ^. attrClass cssUniqueNumber :: ASetter DrawAttributes DrawAttributes@@ -383,13 +383,14 @@ attr & setter .~ Last (Just n) cssUniqueNumber _ attr _ = attr -cssUniqueFloat :: ASetter DrawAttributes DrawAttributes a (Maybe Float)+cssUniqueFloat :: (Fractional n)+ => ASetter DrawAttributes DrawAttributes a (Maybe n) -> CssUpdater cssUniqueFloat setter attr ((CssNumber (Num n):_):_) =- attr & setter .~ Just n+ attr & setter .~ Just (realToFrac n) cssUniqueFloat _ attr _ = attr -cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Float)+cssUniqueMayFloat :: ASetter DrawAttributes DrawAttributes a (Last Double) -> CssUpdater cssUniqueMayFloat setter attr ((CssNumber (Num n):_):_) = attr & setter .~ Last (Just n)@@ -469,7 +470,7 @@ ,("font-size" `parseIn` fontSize, cssUniqueNumber fontSize) ,(parserLastSetter "font-family" fontFamily (Just . commaSeparate) (Just . intercalate ", "), fontFamilyParser)- + ,("fill-rule" `parseIn` fillRule, cssIdentAttr fillRule) ,("clip-rule" `parseIn` clipRule, cssIdentAttr clipRule) ,("mask" `parseIn` maskRef, cssElementRefSetter maskRef)@@ -490,7 +491,7 @@ serializeDashArray :: [Number] -> String serializeDashArray =- intercalate ", " . fmap serializeNumber + intercalate ", " . fmap serializeNumber instance XMLUpdatable DrawAttributes where xmlTagName _ = "DRAWATTRIBUTES"@@ -608,8 +609,8 @@ xmlTagName _ = "linearGradient" serializeTreeNode node = updateWithAccessor _linearGradientStops node $ genericSerializeNode node- - attributes = ++ attributes = ["gradientTransform" `parseIn` linearGradientTransform ,"gradientUnits" `parseIn` linearGradientUnits ,"spreadMethod" `parseIn` linearGradientSpread@@ -701,7 +702,7 @@ ,parserSetter "y" textInfoY (parse dashArray) dashNotEmpty ,parserSetter "dx" textInfoDX (parse dashArray) dashNotEmpty ,parserSetter "dy" textInfoDY (parse dashArray) dashNotEmpty- ,parserSetter "rotate" textInfoRotate + ,parserSetter "rotate" textInfoRotate (parse numberList) rotateNotEmpty ,"textLength" `parseIn` textInfoLength@@ -736,7 +737,7 @@ serializeTreeNode node = updateWithAccessor _patternElements node $ genericSerializeWithDrawAttr node attributes =- ["viewBox" `parseIn` patternViewBox + ["viewBox" `parseIn` patternViewBox ,"patternUnits" `parseIn` patternUnit ,"width" `parseIn` patternWidth ,"height" `parseIn` patternHeight@@ -760,8 +761,8 @@ serializeText :: Text -> X.Element serializeText topText = topNode { X.elName = X.unqual "text" } where- topNode = serializeSpan $ _textRoot topText - + topNode = serializeSpan $ _textRoot topText+ serializeSpan tspan = setChildren (mergeAttributes info drawInfo) subContent where info = genericSerializeNode $ _spanInfo tspan@@ -786,13 +787,13 @@ (sub, _, restStrip) = go startStrip $ X.elContent e spans = TextSpan (xmlUnparse e) (xmlUnparse e) sub - go startStrip (X.Elem e@(nodeName -> "tref"):rest) = + go startStrip (X.Elem e@(nodeName -> "tref"):rest) = case attributeFinder "href" e of Nothing -> go startStrip rest Just v -> (SpanTextRef v : trest, mpath, stripRet) where (trest, mpath, stripRet) = go startStrip rest - go startStrip (X.Elem e@(nodeName -> "textPath"):rest) = + go startStrip (X.Elem e@(nodeName -> "textPath"):rest) = case attributeFinder "href" e of Nothing -> go startStrip rest Just v -> (tsub ++ trest, pure p, retStrp)@@ -835,8 +836,8 @@ where percentage = floor . (100 *) $ a ^. gradientOffset :: Int setter el str = el & gradientOffset .~ val- where - val = case parseMayStartDot complexNumber str of+ where+ val = realToFrac $ case parseMayStartDot complexNumber str of Nothing -> 0 Just (Num n) -> n Just (Px n) -> n@@ -855,8 +856,8 @@ [gradientOffsetSetter ,"stop-color" `parseIn` gradientColor ]- + data Symbols = Symbols { symbols :: !(M.Map String Element) , cssStyle :: [CssRule]@@ -864,7 +865,7 @@ emptyState :: Symbols emptyState = Symbols mempty mempty- + parseGradientStops :: X.Element -> [GradientStop] parseGradientStops = concatMap unStop . elChildren where@@ -940,7 +941,7 @@ let realChildren = filter isNotNone children groupNode :: Group Tree- groupNode = xmlUnparseWithDrawAttr e + groupNode = xmlUnparseWithDrawAttr e pure $ GroupTree $ groupNode & groupChildren .~ realChildren @@ -949,7 +950,7 @@ pure . TextTree pathWithGeometry $ xmlUnparse e & textRoot .~ root where (textContent, tPath) = unparseText $ X.elContent e- + pathGeomtryOf Nothing = pure Nothing pathGeomtryOf (Just pathInfo) = do pathElem <- gets $ M.lookup (_textPathName pathInfo) . symbols@@ -987,7 +988,7 @@ parsed = xmlUnparseWithDrawAttr e unparseDocument :: FilePath -> X.Element -> Maybe Document-unparseDocument rootLocation e@(nodeName -> "svg") = Just Document +unparseDocument rootLocation e@(nodeName -> "svg") = Just Document { _viewBox = attributeFinder "viewBox" e >>= parse viewBoxParser , _elements = parsedElements@@ -1003,7 +1004,7 @@ runState (mapM unparse $ elChildren e) emptyState lengthFind n = attributeFinder n e >>= parse complexNumber-unparseDocument _ _ = Nothing +unparseDocument _ _ = Nothing -- | Transform a SVG document to a XML node. xmlOfDocument :: Document -> X.Element
svg-tree.cabal view
@@ -1,5 +1,5 @@ name: svg-tree-version: 0.2+version: 0.3 synopsis: SVG file loader and serializer description: svg-tree provides types representing a SVG document,@@ -15,7 +15,7 @@ license: BSD3 author: Vincent Berthoux maintainer: Vincent Berthoux--- copyright: +-- copyright: category: Graphics, Svg build-type: Simple cabal-version: >=1.10@@ -29,7 +29,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/svg-tree.git- Tag: v0.2+ Tag: v0.3 library hs-source-dirs: src