svg-tree 0.6.2.3 → 0.6.2.4

raw patch · 5 files changed

+540/−531 lines, 5 filesdep ~lensdep ~mtldep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: lens, mtl, transformers

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• src/Graphics/Svg.hs +6/−1
• src/Graphics/Svg/CssParser.hs +257/−257
• src/Graphics/Svg/CssTypes.hs +271/−271
• svg-tree.cabal +2/−2

@@ -1,5 +1,9 @@ -*-change-log-*-
 
+v0.6.2.4 June 2019
+
+ * Hopefully not crashing in the presence of unicode inputs (on windows)
+
 v0.6.2.3 October 2018
 
  * GHC 8.6 fixes

@@ -25,6 +25,7 @@ import qualified Data.ByteString as B
 import qualified Data.Map as M
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import Text.XML.Light.Input( parseXMLDoc )
 import Text.XML.Light.Output( ppcTopElement, prettyConfigPP )
 import Control.Lens
@@ -53,7 +54,11 @@ -- | Save a svg Document on a file on disk.
 saveXmlFile :: FilePath -> Document -> IO ()
 saveXmlFile filePath =
-    writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument
+    B.writeFile filePath
+        . T.encodeUtf8
+        . T.pack
+        . ppcTopElement prettyConfigPP
+        . xmlOfDocument
 
 cssDeclApplyer :: DrawAttributes -> CssDeclaration
                -> DrawAttributes

@@ -1,257 +1,257 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards #-}
-module Graphics.Svg.CssParser
-    ( CssElement( .. )
-    , complexNumber
-    , declaration
-    , ruleSet
-    , styleString
-    , dashArray
-    , numberList
-    , num
-    , cssRulesOfText
-    )
-    where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( (<*>), (<*), (*>)
-                          , (<$>), (<$)
-                          , pure
-                          )
-#endif
-
-import Control.Applicative( (<|>)
-                          , many
-                          )
-import Data.Attoparsec.Text
-    ( Parser
-    , double
-    , string
-    , skipSpace
-    , letter
-    , char
-    , digit
-    {-, skip-}
-    , sepBy1
-    , (<?>)
-    , skipMany
-    , notChar
-    , parseOnly
-    )
-import qualified Data.Attoparsec.Text as AT
-
-import Data.Attoparsec.Combinator
-    ( option
-    , sepBy
-    {-, sepBy1-}
-    , many1
-    )
-
-import Codec.Picture( PixelRGBA8( .. ) )
-import Graphics.Svg.Types
-import Graphics.Svg.NamedColors( svgNamedColors )
-import Graphics.Svg.ColorParser( colorParser )
-import Graphics.Svg.CssTypes
-import qualified Data.Text as T
-import qualified Data.Map as M
-{-import Graphics.Rasterific.Linear( V2( V2 ) )-}
-{-import Graphics.Rasterific.Transformations-}
-
-num :: Parser Double
-num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)
-  where doubleNumber = char '.' *> (scale <$> double)
-                    <|> double
-
-        scalingCoeff n = 10 ^ digitCount
-          where digitCount :: Int
-                digitCount = ceiling . logBase 10 $ abs n
-
-        scale n = n / scalingCoeff n
-
-        plusMinus = negate <$ string "-" <*> doubleNumber
-                 <|> string "+" *> doubleNumber
-                 <|> doubleNumber
-
-
-ident :: Parser T.Text
-ident =
-  (\f c -> f . T.cons c . T.pack)
-        <$> trailingSub
-        <*> nmstart <*> nmchar
-  where
-    trailingSub = option id $ T.cons '-' <$ char '-'
-    underscore = char '_'
-    nmstart = letter <|> underscore
-    nmchar = many (letter <|> digit <|> underscore <|> char '-')
-
-str :: Parser T.Text
-str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace
-   <?> "str"
-
-between :: Char -> Char -> Parser a -> Parser a
-between o e p =
-  (skipSpace *>
-      char o *> skipSpace *> p
-           <* skipSpace <* char e <* skipSpace)
-           <?> ("between " ++ [o, e])
-
-bracket :: Parser a -> Parser a
-bracket = between '[' ']'
-
-
-comment :: Parser ()
-comment = string "/*" *> toStar *> skipSpace
-  where
-    toStar = skipMany (notChar '*') *> char '*' *> testEnd
-    testEnd = (() <$ char '/') <|> toStar
-
-cleanSpace :: Parser ()
-cleanSpace = skipSpace <* many comment
-
--- | combinator: '+' S* | '>' S*
-combinator :: Parser CssSelector
-combinator = parse <* cleanSpace where
-  parse = Nearby <$ char '+'
-       <|> DirectChildren <$ char '>'
-       <?> "combinator"
-
--- unary_operator : '-' | '+' ;
-
-commaWsp :: Parser Char
-commaWsp = skipSpace *> option ',' (char ',') <* skipSpace
-
-ruleSet :: Parser CssRule
-ruleSet = cleanSpace *> rule where
-  rule = CssRule
-      <$> selector `sepBy1` commaWsp
-      <*> (between '{' '}' styleString)
-      <?> "cssrule"
-
-styleString :: Parser [CssDeclaration]
-styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp
-           <?> "styleString"
-  where semiWsp = skipSpace *> char ';' <* skipSpace
-        mayWsp = option ';' semiWsp
-
-selector :: Parser [CssSelector]
-selector = (:)
-        <$> (AllOf <$> simpleSelector <* skipSpace <?> "firstpart:(")
-        <*> ((next <|> return []) <?> "secondpart")
-        <?> "selector"
-  where
-    combOpt :: Parser ([CssSelector] -> [CssSelector])
-
-    combOpt = cleanSpace *> option id ((:) <$> combinator)
-    next :: Parser [CssSelector]
-    next = id <$> combOpt <*> selector
-
-simpleSelector :: Parser [CssDescriptor]
-simpleSelector = (:) <$> elementName <*> many whole
-              <|> (many1 whole <?> "inmany")
-              <?> "simple selector"
- where
-  whole = pseudo <|> hash <|> classParser <|> attrib
-       <?> "whole"
-  pseudo = char ':' *> (OfPseudoClass <$> ident)
-        <?> "pseudo"
-  hash = char '#' *> (OfId <$> ident)
-      <?> "hash"
-  classParser = char '.' *> (OfClass <$> ident)
-              <?> "classParser"
-
-  elementName = el <* skipSpace <?> "elementName"
-    where el = (OfName <$> ident)
-            <|> AnyElem <$ char '*'
-
-  attrib = bracket
-    (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str))
-           <?> "attrib")
-
-declaration :: Parser CssDeclaration
-declaration =
-  CssDeclaration <$> property
-                 <*> (char ':'
-                      *> cleanSpace
-                      *> many1 expr
-                      <* prio
-                      )
-                 <?> "declaration"
-  where
-    property = (ident <* cleanSpace) <?> "property"
-    prio = option "" $ string "!important"
-
-operator :: Parser CssElement
-operator = skipSpace *> op <* skipSpace
-  where
-    op = CssOpSlash <$ char '/'
-      <|> CssOpComa <$ char ','
-      <?> "operator"
-
-expr :: Parser [CssElement]
-expr = ((:) <$> term <*> (concat <$> many termOp))
-    <?> "expr"
-  where
-    op = option (:[]) $ (\a b -> [a, b]) <$> operator
-    termOp = ($) <$> op <*> term
-
-dashArray :: Parser [Number]
-dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp)
-
-numberList :: Parser [Double]
-numberList = skipSpace *> (num `sepBy1` commaWsp)
-
-complexNumber :: Parser Number
-complexNumber = do
-    n <- num
-    (Percent (n / 100) <$ char '%')
-        <|> (Em n <$ string "em")
-        <|> (Mm n <$ string "mm")
-        <|> (Cm n <$ string "cm")
-        <|> (Point n <$ string "pt")
-        <|> (Pc n <$ string "pc")
-        <|> (Px n <$ string "px")
-        <|> (Inches n <$ string "in")
-        <|> pure (Num n)
-
-term :: Parser CssElement
-term = checkRgb <$> function
-    <|> (CssNumber <$> complexNumber)
-    <|> (CssString <$> str)
-    <|> (checkNamedColor <$> ident)
-    <|> (CssColor <$> colorParser)
-  where
-    comma = skipSpace *> char ',' <* skipSpace
-    checkNamedColor n
-        | Just c <- M.lookup n svgNamedColors = CssColor c
-        | otherwise = CssIdent n
-
-    ref = char '#' *> ident
-
-    checkRgb (CssFunction "rgb"
-                [CssNumber r, CssNumber g, CssNumber b]) =
-        CssColor $ PixelRGBA8 (to r) (to g) (to b) 255
-       where clamp = max 0 . min 255
-             to (Num n) = floor $ clamp n
-             to (Px n) = floor $ clamp n
-             to (Percent p) = floor . clamp $ p * 255
-             to (Em c) = floor $ clamp c
-             to (Pc n) = floor $ clamp n
-             to (Mm n) = floor $ clamp n
-             to (Cm n) = floor $ clamp n
-             to (Point n) = floor $ clamp n
-             to (Inches n) = floor $ clamp n
-
-    checkRgb a = a
-    functionParam = (CssReference <$> ref) <|> term
-
-    function = CssFunction
-       <$> ident <* char '('
-       <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace
-
--- | Parse CSS text into rules.
-cssRulesOfText :: T.Text -> [CssRule]
-cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of
-    Left _ -> []
-    Right rules -> rules
-
+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+module Graphics.Svg.CssParser+    ( CssElement( .. )+    , complexNumber+    , declaration+    , ruleSet+    , styleString+    , dashArray+    , numberList+    , num+    , cssRulesOfText+    )+    where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<*), (*>)+                          , (<$>), (<$)+                          , pure+                          )+#endif++import Control.Applicative( (<|>)+                          , many+                          )+import Data.Attoparsec.Text+    ( Parser+    , double+    , string+    , skipSpace+    , letter+    , char+    , digit+    {-, skip-}+    , sepBy1+    , (<?>)+    , skipMany+    , notChar+    , parseOnly+    )+import qualified Data.Attoparsec.Text as AT++import Data.Attoparsec.Combinator+    ( option+    , sepBy+    {-, sepBy1-}+    , many1+    )++import Codec.Picture( PixelRGBA8( .. ) )+import Graphics.Svg.Types+import Graphics.Svg.NamedColors( svgNamedColors )+import Graphics.Svg.ColorParser( colorParser )+import Graphics.Svg.CssTypes+import qualified Data.Text as T+import qualified Data.Map as M+{-import Graphics.Rasterific.Linear( V2( V2 ) )-}+{-import Graphics.Rasterific.Transformations-}++num :: Parser Double+num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)+  where doubleNumber = char '.' *> (scale <$> double)+                    <|> double++        scalingCoeff n = 10 ^ digitCount+          where digitCount :: Int+                digitCount = ceiling . logBase 10 $ abs n++        scale n = n / scalingCoeff n++        plusMinus = negate <$ string "-" <*> doubleNumber+                 <|> string "+" *> doubleNumber+                 <|> doubleNumber+++ident :: Parser T.Text+ident =+  (\f c -> f . T.cons c . T.pack)+        <$> trailingSub+        <*> nmstart <*> nmchar+  where+    trailingSub = option id $ T.cons '-' <$ char '-'+    underscore = char '_'+    nmstart = letter <|> underscore+    nmchar = many (letter <|> digit <|> underscore <|> char '-')++str :: Parser T.Text+str = char '"' *> AT.takeWhile (/= '"') <* char '"' <* skipSpace+   <?> "str"++between :: Char -> Char -> Parser a -> Parser a+between o e p =+  (skipSpace *>+      char o *> skipSpace *> p+           <* skipSpace <* char e <* skipSpace)+           <?> ("between " ++ [o, e])++bracket :: Parser a -> Parser a+bracket = between '[' ']'+++comment :: Parser ()+comment = string "/*" *> toStar *> skipSpace+  where+    toStar = skipMany (notChar '*') *> char '*' *> testEnd+    testEnd = (() <$ char '/') <|> toStar++cleanSpace :: Parser ()+cleanSpace = skipSpace <* many comment++-- | combinator: '+' S* | '>' S*+combinator :: Parser CssSelector+combinator = parse <* cleanSpace where+  parse = Nearby <$ char '+'+       <|> DirectChildren <$ char '>'+       <?> "combinator"++-- unary_operator : '-' | '+' ;++commaWsp :: Parser Char+commaWsp = skipSpace *> option ',' (char ',') <* skipSpace++ruleSet :: Parser CssRule+ruleSet = cleanSpace *> rule where+  rule = CssRule+      <$> selector `sepBy1` commaWsp+      <*> (between '{' '}' styleString)+      <?> "cssrule"++styleString :: Parser [CssDeclaration]+styleString = ((cleanSpace *> declaration) `sepBy` semiWsp) <* mayWsp+           <?> "styleString"+  where semiWsp = skipSpace *> char ';' <* skipSpace+        mayWsp = option ';' semiWsp++selector :: Parser [CssSelector]+selector = (:)+        <$> (AllOf <$> simpleSelector <* skipSpace <?> "firstpart:(")+        <*> ((next <|> return []) <?> "secondpart")+        <?> "selector"+  where+    combOpt :: Parser ([CssSelector] -> [CssSelector])++    combOpt = cleanSpace *> option id ((:) <$> combinator)+    next :: Parser [CssSelector]+    next = id <$> combOpt <*> selector++simpleSelector :: Parser [CssDescriptor]+simpleSelector = (:) <$> elementName <*> many whole+              <|> (many1 whole <?> "inmany")+              <?> "simple selector"+ where+  whole = pseudo <|> hash <|> classParser <|> attrib+       <?> "whole"+  pseudo = char ':' *> (OfPseudoClass <$> ident)+        <?> "pseudo"+  hash = char '#' *> (OfId <$> ident)+      <?> "hash"+  classParser = char '.' *> (OfClass <$> ident)+              <?> "classParser"++  elementName = el <* skipSpace <?> "elementName"+    where el = (OfName <$> ident)+            <|> AnyElem <$ char '*'++  attrib = bracket+    (WithAttrib <$> ident <*> (char '=' *> skipSpace *> (ident <|> str))+           <?> "attrib")++declaration :: Parser CssDeclaration+declaration =+  CssDeclaration <$> property+                 <*> (char ':'+                      *> cleanSpace+                      *> many1 expr+                      <* prio+                      )+                 <?> "declaration"+  where+    property = (ident <* cleanSpace) <?> "property"+    prio = option "" $ string "!important"++operator :: Parser CssElement+operator = skipSpace *> op <* skipSpace+  where+    op = CssOpSlash <$ char '/'+      <|> CssOpComa <$ char ','+      <?> "operator"++expr :: Parser [CssElement]+expr = ((:) <$> term <*> (concat <$> many termOp))+    <?> "expr"+  where+    op = option (:[]) $ (\a b -> [a, b]) <$> operator+    termOp = ($) <$> op <*> term++dashArray :: Parser [Number]+dashArray = skipSpace *> (complexNumber `sepBy1` commaWsp)++numberList :: Parser [Double]+numberList = skipSpace *> (num `sepBy1` commaWsp)++complexNumber :: Parser Number+complexNumber = do+    n <- num+    (Percent (n / 100) <$ char '%')+        <|> (Em n <$ string "em")+        <|> (Mm n <$ string "mm")+        <|> (Cm n <$ string "cm")+        <|> (Point n <$ string "pt")+        <|> (Pc n <$ string "pc")+        <|> (Px n <$ string "px")+        <|> (Inches n <$ string "in")+        <|> pure (Num n)++term :: Parser CssElement+term = checkRgb <$> function+    <|> (CssNumber <$> complexNumber)+    <|> (CssString <$> str)+    <|> (checkNamedColor <$> ident)+    <|> (CssColor <$> colorParser)+  where+    comma = skipSpace *> char ',' <* skipSpace+    checkNamedColor n+        | Just c <- M.lookup n svgNamedColors = CssColor c+        | otherwise = CssIdent n++    ref = char '#' *> ident++    checkRgb (CssFunction "rgb"+                [CssNumber r, CssNumber g, CssNumber b]) =+        CssColor $ PixelRGBA8 (to r) (to g) (to b) 255+       where clamp = max 0 . min 255+             to (Num n) = floor $ clamp n+             to (Px n) = floor $ clamp n+             to (Percent p) = floor . clamp $ p * 255+             to (Em c) = floor $ clamp c+             to (Pc n) = floor $ clamp n+             to (Mm n) = floor $ clamp n+             to (Cm n) = floor $ clamp n+             to (Point n) = floor $ clamp n+             to (Inches n) = floor $ clamp n++    checkRgb a = a+    functionParam = (CssReference <$> ref) <|> term++    function = CssFunction+       <$> ident <* char '('+       <*> (functionParam `sepBy` comma) <* char ')' <* skipSpace++-- | Parse CSS text into rules.+cssRulesOfText :: T.Text -> [CssRule]+cssRulesOfText txt = case parseOnly (many1 ruleSet) $ txt of+    Left _ -> []+    Right rules -> rules+

@@ -1,271 +1,271 @@-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
--- | Define the types used to describes CSS elements
-module Graphics.Svg.CssTypes
-    ( CssSelector( .. )
-    , CssSelectorRule
-    , CssRule( .. )
-    , CssDescriptor( .. )
-    , CssDeclaration( .. )
-    , CssElement( .. )
-
-    , CssMatcheable( .. )
-    , CssContext
-    , Dpi
-    , Number( .. )
-    , serializeNumber
-    , findMatchingDeclarations
-    , toUserUnit
-    , mapNumber
-    , tserialize
-    ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Data.Monoid( mconcat )
-#endif
-
-import Data.Monoid( (<>) )
-import Data.List( intersperse )
-import qualified Data.Text as T
-import qualified Data.Text.Lazy.Builder as TB
-import Text.Printf
-
-import Codec.Picture( PixelRGBA8( .. ) )
-
--- | Alias describing a "dot per inch" information
--- used for size calculation (see toUserUnit).
-type Dpi = Int
-
--- | Helper typeclass for serialization to Text.
-class TextBuildable a where
-    -- | Serialize an element to a text builder.
-    tserialize :: a -> TB.Builder
-
--- | Describe an element of a CSS selector. Multiple
--- elements can be combined in a CssSelector type.
-data CssDescriptor
-  = OfClass T.Text    -- ^ .IDENT
-  | OfName  T.Text    -- ^ IDENT
-  | OfId    T.Text    -- ^ #IDENT
-  | OfPseudoClass T.Text     -- ^ `:IDENT` (ignore function syntax)
-  | AnyElem                  -- ^ '*'
-  | WithAttrib T.Text T.Text -- ^ ``
-  deriving (Eq, Show)
-
-instance TextBuildable CssDescriptor where
-  tserialize d = case d of
-      OfClass c -> si '.' <> ft c
-      OfName  n -> ft n
-      OfId    i -> si '#' <> ft i
-      OfPseudoClass c -> si '#' <> ft c
-      AnyElem -> si '*'
-      WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']']
-     where
-      ft = TB.fromText
-      si = TB.singleton
-
--- | Define complex selector.
-data CssSelector
-  = Nearby          -- ^ Correspond to the `+` CSS selector.
-  | DirectChildren  -- ^ Correspond to the `>` CSS selectro.
-  | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements
-                          -- of the list must be matched.
-  deriving (Eq, Show)
-
-instance TextBuildable CssSelector where
-  tserialize s = case s of
-      Nearby -> si '+'
-      DirectChildren -> si '>'
-      AllOf lst -> mconcat $ map tserialize lst
-    where
-      si = TB.singleton
-
--- | A CssSelectorRule is a list of all the elements
--- that must be meet in a depth first search fashion.
-type CssSelectorRule = [CssSelector]
-
--- | Represent a CSS selector and the different declarations
--- to apply to the matched elemens.
-data CssRule = CssRule
-    { -- | At the first level represent a list of elements
-      -- to be matched. If any match is made, you can apply
-      -- the declarations. At the second level
-      cssRuleSelector :: ![CssSelectorRule]
-      -- | Declarations to apply to the matched element.
-    , cssDeclarations :: ![CssDeclaration]
-    }
-    deriving (Eq, Show)
-
-instance TextBuildable CssRule where
-  tserialize (CssRule selectors decl) =
-      mconcat tselectors
-                 <> ft " {\n"
-                 <> mconcat (fmap tserializeDecl decl)
-                 <> ft "}\n"
-     where
-      ft = TB.fromText
-      tserializeDecl d = ft "  " <> tserialize d <> ft ";\n"
-      tselector =
-          mconcat . intersperse (ft " ") . fmap tserialize
-      tselectors = 
-          intersperse (ft ",\n") $ fmap tselector selectors
-
--- | Interface for elements to be matched against
--- some CssRule.
-class CssMatcheable a where
-  -- | For an element, tell its optional ID attribute.
-  cssIdOf     :: a -> Maybe T.Text
-  -- | For an element, return all of it's class attributes.
-  cssClassOf  :: a -> [T.Text]
-  -- | Return the name of the tagname of the element
-  cssNameOf   :: a -> T.Text
-  -- | Return a value of a given attribute if present
-  cssAttribOf :: a -> T.Text -> Maybe T.Text
-
--- | Represent a zipper in depth at the first list
--- level, and the previous nodes at in the second
--- list level.
-type CssContext a = [[a]]
-
-isDescribedBy :: CssMatcheable a
-              => a -> [CssDescriptor] -> Bool
-isDescribedBy e = all tryMatch
-  where
-    tryMatch (OfClass t) = t `elem` cssClassOf e
-    tryMatch (OfId    i) = cssIdOf e == Just i
-    tryMatch (OfName  n) = cssNameOf e == n
-    tryMatch (OfPseudoClass _) = False
-    tryMatch (WithAttrib a v) = cssAttribOf e a == Just v
-    tryMatch AnyElem = True
-
-isMatching :: CssMatcheable a
-           => CssContext a -> [CssSelector] -> Bool
-isMatching = go where
-  go  _ [] = True
-  go []  _ = False
-  go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest
-  go ((e:_):upper) (DirectChildren:AllOf descr:rest)
-    | isDescribedBy e descr = go upper rest
-  go _ (DirectChildren:_) = False
-  go ((e:_):upper) selectors@(AllOf descr : rest)
-    | isDescribedBy e descr = go upper rest
-    | otherwise = go upper selectors
-  go (_:upper) selector = go upper selector
-
--- | Given CSS rules, find all the declaration to apply to the
--- element in a given context.
-findMatchingDeclarations :: CssMatcheable a
-                         => [CssRule] -> CssContext a -> [CssDeclaration]
-findMatchingDeclarations rules context =
-    concat [cssDeclarations rule
-                    | rule <- rules
-                    , selector <- cssRuleSelector rule
-                    , isMatching context $ reverse selector ]
-
--- | Represent the content to apply to some
--- CSS matched rules.
-data CssDeclaration = CssDeclaration
-    { -- | Property name to change (like font-family or color).
-      _cssDeclarationProperty :: T.Text
-      -- | List of values
-    , _cssDecarationlValues   :: [[CssElement]]
-    }
-    deriving (Eq, Show)
-
-instance TextBuildable CssDeclaration where
-  tserialize (CssDeclaration n elems) =
-      mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems
-     where
-      finalElems = map tserialize (concat elems)
-      ft = TB.fromText
-      si = TB.singleton
-
-
--- | Encode complex number possibly dependant to the current
--- render size.
-data Number
-  = Num Double       -- ^ Simple coordinate in current user coordinate.
-  | Px Double        -- ^ With suffix "px"
-  | Em Double        -- ^ Number relative to the current font size.
-  | Percent Double   -- ^ Number relative to the current viewport size.
-  | Pc Double
-  | Mm Double        -- ^ Number in millimeters, relative to DPI.
-  | Cm Double        -- ^ Number in centimeters, relative to DPI.
-  | Point Double     -- ^ Number in points, relative to DPI.
-  | Inches Double    -- ^ Number in inches, relative to DPI.
-  deriving (Eq, Show)
-
--- | Helper function to modify inner value of a number
-mapNumber :: (Double -> Double) -> Number -> Number
-mapNumber f nu = case nu of
-  Num n -> Num $ f n
-  Px n -> Px $ f n
-  Em n -> Em $ f n
-  Percent n -> Percent $ f n
-  Pc n -> Pc $ f n
-  Mm n -> Mm $ f n
-  Cm n -> Cm $ f n
-  Point n -> Point $ f n
-  Inches n -> Inches $ f n
-
--- | Encode the number to string which can be used in a
--- CSS or a svg attributes.
-serializeNumber :: Number -> String
-serializeNumber n = case n of
-    Num c -> printf "%g" c
-    Px c -> printf "%gpx" c
-    Em cc -> printf "%gem" cc
-    Percent p -> printf "%d%%" (floor $ 100 * p :: Int)
-    Pc p -> printf "%gpc" p
-    Mm m -> printf "%gmm" m
-    Cm c -> printf "%gcm" c
-    Point p -> printf "%gpt" p
-    Inches i -> printf "%gin" i
-
-instance TextBuildable Number where
-   tserialize = TB.fromText . T.pack . serializeNumber
-
--- | Value of a CSS property.
-data CssElement
-    = CssIdent     !T.Text
-    | CssString    !T.Text
-    | CssReference !T.Text
-    | CssNumber    !Number
-    | CssColor     !PixelRGBA8
-    | CssFunction  !T.Text ![CssElement]
-    | CssOpComa
-    | CssOpSlash
-    deriving (Eq, Show)
-
-instance TextBuildable CssElement where
-  tserialize e = case e of
-    CssIdent    n -> ft n
-    CssString   s -> si '"' <> ft s <> si '"'
-    CssReference r -> si '#' <> ft r
-    CssNumber   n -> tserialize n
-    CssColor  (PixelRGBA8 r g b _) ->
-      ft . T.pack $ printf  "#%02X%02X%02X" r g b
-    CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')']
-        where args = intersperse (ft ", ") (map tserialize els)
-    CssOpComa -> si ','
-    CssOpSlash -> si '/'
-    where
-      ft = TB.fromText
-      si = TB.singleton
-
--- | This function replace all device dependant units to user
--- units given it's DPI configuration.
--- Preserve percentage and "em" notation.
-toUserUnit :: Dpi -> Number -> Number
-toUserUnit dpi = go where
-  go nu = case nu of
-    Num _ -> nu
-    Px p -> go $ Num p
-    Em _ -> nu
-    Percent _ -> nu
-    Pc n -> go . Inches $ (12 * n) / 72
-    Inches n -> Num $ n * fromIntegral dpi
-    Mm n -> go . Inches $ n / 25.4
-    Cm n -> go . Inches $ n / 2.54
-    Point n -> go . Inches $ n / 72
-
+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+-- | Define the types used to describes CSS elements+module Graphics.Svg.CssTypes+    ( CssSelector( .. )+    , CssSelectorRule+    , CssRule( .. )+    , CssDescriptor( .. )+    , CssDeclaration( .. )+    , CssElement( .. )++    , CssMatcheable( .. )+    , CssContext+    , Dpi+    , Number( .. )+    , serializeNumber+    , findMatchingDeclarations+    , toUserUnit+    , mapNumber+    , tserialize+    ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mconcat )+#endif++import Data.Monoid( (<>) )+import Data.List( intersperse )+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TB+import Text.Printf++import Codec.Picture( PixelRGBA8( .. ) )++-- | Alias describing a "dot per inch" information+-- used for size calculation (see toUserUnit).+type Dpi = Int++-- | Helper typeclass for serialization to Text.+class TextBuildable a where+    -- | Serialize an element to a text builder.+    tserialize :: a -> TB.Builder++-- | Describe an element of a CSS selector. Multiple+-- elements can be combined in a CssSelector type.+data CssDescriptor+  = OfClass T.Text    -- ^ .IDENT+  | OfName  T.Text    -- ^ IDENT+  | OfId    T.Text    -- ^ #IDENT+  | OfPseudoClass T.Text     -- ^ `:IDENT` (ignore function syntax)+  | AnyElem                  -- ^ '*'+  | WithAttrib T.Text T.Text -- ^ ``+  deriving (Eq, Show)++instance TextBuildable CssDescriptor where+  tserialize d = case d of+      OfClass c -> si '.' <> ft c+      OfName  n -> ft n+      OfId    i -> si '#' <> ft i+      OfPseudoClass c -> si '#' <> ft c+      AnyElem -> si '*'+      WithAttrib a b -> mconcat [si '[', ft a, si '=', ft b, si ']']+     where+      ft = TB.fromText+      si = TB.singleton++-- | Define complex selector.+data CssSelector+  = Nearby          -- ^ Correspond to the `+` CSS selector.+  | DirectChildren  -- ^ Correspond to the `>` CSS selectro.+  | AllOf [CssDescriptor] -- ^ Grouping construct, all the elements+                          -- of the list must be matched.+  deriving (Eq, Show)++instance TextBuildable CssSelector where+  tserialize s = case s of+      Nearby -> si '+'+      DirectChildren -> si '>'+      AllOf lst -> mconcat $ map tserialize lst+    where+      si = TB.singleton++-- | A CssSelectorRule is a list of all the elements+-- that must be meet in a depth first search fashion.+type CssSelectorRule = [CssSelector]++-- | Represent a CSS selector and the different declarations+-- to apply to the matched elemens.+data CssRule = CssRule+    { -- | At the first level represent a list of elements+      -- to be matched. If any match is made, you can apply+      -- the declarations. At the second level+      cssRuleSelector :: ![CssSelectorRule]+      -- | Declarations to apply to the matched element.+    , cssDeclarations :: ![CssDeclaration]+    }+    deriving (Eq, Show)++instance TextBuildable CssRule where+  tserialize (CssRule selectors decl) =+      mconcat tselectors+                 <> ft " {\n"+                 <> mconcat (fmap tserializeDecl decl)+                 <> ft "}\n"+     where+      ft = TB.fromText+      tserializeDecl d = ft "  " <> tserialize d <> ft ";\n"+      tselector =+          mconcat . intersperse (ft " ") . fmap tserialize+      tselectors = +          intersperse (ft ",\n") $ fmap tselector selectors++-- | Interface for elements to be matched against+-- some CssRule.+class CssMatcheable a where+  -- | For an element, tell its optional ID attribute.+  cssIdOf     :: a -> Maybe T.Text+  -- | For an element, return all of it's class attributes.+  cssClassOf  :: a -> [T.Text]+  -- | Return the name of the tagname of the element+  cssNameOf   :: a -> T.Text+  -- | Return a value of a given attribute if present+  cssAttribOf :: a -> T.Text -> Maybe T.Text++-- | Represent a zipper in depth at the first list+-- level, and the previous nodes at in the second+-- list level.+type CssContext a = [[a]]++isDescribedBy :: CssMatcheable a+              => a -> [CssDescriptor] -> Bool+isDescribedBy e = all tryMatch+  where+    tryMatch (OfClass t) = t `elem` cssClassOf e+    tryMatch (OfId    i) = cssIdOf e == Just i+    tryMatch (OfName  n) = cssNameOf e == n+    tryMatch (OfPseudoClass _) = False+    tryMatch (WithAttrib a v) = cssAttribOf e a == Just v+    tryMatch AnyElem = True++isMatching :: CssMatcheable a+           => CssContext a -> [CssSelector] -> Bool+isMatching = go where+  go  _ [] = True+  go []  _ = False+  go ((_ : near):upper) (Nearby : rest) = go (near:upper) rest+  go ((e:_):upper) (DirectChildren:AllOf descr:rest)+    | isDescribedBy e descr = go upper rest+  go _ (DirectChildren:_) = False+  go ((e:_):upper) selectors@(AllOf descr : rest)+    | isDescribedBy e descr = go upper rest+    | otherwise = go upper selectors+  go (_:upper) selector = go upper selector++-- | Given CSS rules, find all the declaration to apply to the+-- element in a given context.+findMatchingDeclarations :: CssMatcheable a+                         => [CssRule] -> CssContext a -> [CssDeclaration]+findMatchingDeclarations rules context =+    concat [cssDeclarations rule+                    | rule <- rules+                    , selector <- cssRuleSelector rule+                    , isMatching context $ reverse selector ]++-- | Represent the content to apply to some+-- CSS matched rules.+data CssDeclaration = CssDeclaration+    { -- | Property name to change (like font-family or color).+      _cssDeclarationProperty :: T.Text+      -- | List of values+    , _cssDecarationlValues   :: [[CssElement]]+    }+    deriving (Eq, Show)++instance TextBuildable CssDeclaration where+  tserialize (CssDeclaration n elems) =+      mconcat $ ft n : ft ": " : intersperse (si ' ') finalElems+     where+      finalElems = map tserialize (concat elems)+      ft = TB.fromText+      si = TB.singleton+++-- | Encode complex number possibly dependant to the current+-- render size.+data Number+  = Num Double       -- ^ Simple coordinate in current user coordinate.+  | Px Double        -- ^ With suffix "px"+  | Em Double        -- ^ Number relative to the current font size.+  | Percent Double   -- ^ Number relative to the current viewport size.+  | Pc Double+  | Mm Double        -- ^ Number in millimeters, relative to DPI.+  | Cm Double        -- ^ Number in centimeters, relative to DPI.+  | Point Double     -- ^ Number in points, relative to DPI.+  | Inches Double    -- ^ Number in inches, relative to DPI.+  deriving (Eq, Show)++-- | Helper function to modify inner value of a number+mapNumber :: (Double -> Double) -> Number -> Number+mapNumber f nu = case nu of+  Num n -> Num $ f n+  Px n -> Px $ f n+  Em n -> Em $ f n+  Percent n -> Percent $ f n+  Pc n -> Pc $ f n+  Mm n -> Mm $ f n+  Cm n -> Cm $ f n+  Point n -> Point $ f n+  Inches n -> Inches $ f n++-- | Encode the number to string which can be used in a+-- CSS or a svg attributes.+serializeNumber :: Number -> String+serializeNumber n = case n of+    Num c -> printf "%g" c+    Px c -> printf "%gpx" c+    Em cc -> printf "%gem" cc+    Percent p -> printf "%d%%" (floor $ 100 * p :: Int)+    Pc p -> printf "%gpc" p+    Mm m -> printf "%gmm" m+    Cm c -> printf "%gcm" c+    Point p -> printf "%gpt" p+    Inches i -> printf "%gin" i++instance TextBuildable Number where+   tserialize = TB.fromText . T.pack . serializeNumber++-- | Value of a CSS property.+data CssElement+    = CssIdent     !T.Text+    | CssString    !T.Text+    | CssReference !T.Text+    | CssNumber    !Number+    | CssColor     !PixelRGBA8+    | CssFunction  !T.Text ![CssElement]+    | CssOpComa+    | CssOpSlash+    deriving (Eq, Show)++instance TextBuildable CssElement where+  tserialize e = case e of+    CssIdent    n -> ft n+    CssString   s -> si '"' <> ft s <> si '"'+    CssReference r -> si '#' <> ft r+    CssNumber   n -> tserialize n+    CssColor  (PixelRGBA8 r g b _) ->+      ft . T.pack $ printf  "#%02X%02X%02X" r g b+    CssFunction t els -> mconcat $ ft t : si '(' : args ++ [si ')']+        where args = intersperse (ft ", ") (map tserialize els)+    CssOpComa -> si ','+    CssOpSlash -> si '/'+    where+      ft = TB.fromText+      si = TB.singleton++-- | This function replace all device dependant units to user+-- units given it's DPI configuration.+-- Preserve percentage and "em" notation.+toUserUnit :: Dpi -> Number -> Number+toUserUnit dpi = go where+  go nu = case nu of+    Num _ -> nu+    Px p -> go $ Num p+    Em _ -> nu+    Percent _ -> nu+    Pc n -> go . Inches $ (12 * n) / 72+    Inches n -> Num $ n * fromIntegral dpi+    Mm n -> go . Inches $ n / 25.4+    Cm n -> go . Inches $ n / 2.54+    Point n -> go . Inches $ n / 72+

@@ -1,5 +1,5 @@ name:                svg-tree
-version:             0.6.2.3
+version:             0.6.2.4
 synopsis:            SVG file loader and serializer
 description:
   svg-tree provides types representing a SVG document,
@@ -29,7 +29,7 @@ Source-Repository this
     Type:      git
     Location:  git://github.com/Twinside/svg-tree.git
-    Tag:       v0.6.2.3
+    Tag:       v0.6.2.4
 
 library
   hs-source-dirs: src