svg-tree 0.6.2.2 → 0.6.2.3

raw patch · 7 files changed

+913/−905 lines, 7 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• src/Graphics/Svg.hs +112/−112
• src/Graphics/Svg/CssParser.hs +257/−257
• src/Graphics/Svg/CssTypes.hs +271/−271
• src/Graphics/Svg/PathParser.hs +264/−260
• src/Graphics/Svg/Types.hs +1/−1
• svg-tree.cabal +4/−4

@@ -1,5 +1,9 @@ -*-change-log-*-
 
+v0.6.2.3 October 2018
+
+ * GHC 8.6 fixes
+
 v0.6.2.2 December 2017
 
  * Adding `Semigroup` instances for defined `Monoid`, for GHC 8.4

@@ -1,112 +1,112 @@-{-# LANGUAGE CPP #-}--- | Module providing basic input/output for the SVG document,--- for document building, please refer to Graphics.Svg.Types.-module Graphics.Svg ( -- * Saving/Loading functions-                      loadSvgFile-                    , parseSvgFile-                    , xmlOfDocument-                    , saveXmlFile--                      -- * Manipulation functions-                    , cssApply-                    , cssRulesOfText-                    , applyCSSRules-                    , resolveUses--                      -- * Type definitions-                    , module Graphics.Svg.Types-                    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>) )-#endif--import Data.List( foldl' )-import qualified Data.ByteString as B-import qualified Data.Map as M-import qualified Data.Text as T-import Text.XML.Light.Input( parseXMLDoc )-import Text.XML.Light.Output( ppcTopElement, prettyConfigPP )-import Control.Lens--import Graphics.Svg.Types-import Graphics.Svg.CssTypes-import Graphics.Svg.CssParser( cssRulesOfText )-import Graphics.Svg.XmlParser--{-import Graphics.Svg.CssParser-}---- | Try to load an svg file on disc and parse it as--- a SVG Document.-loadSvgFile :: FilePath -> IO (Maybe Document)-loadSvgFile filename =-  parseSvgFile filename <$> B.readFile filename---- | Parse an in-memory SVG file-parseSvgFile :: FilePath    -- ^ Source path/URL of the document, used-                            -- to resolve relative links.-             -> B.ByteString-             -> Maybe Document-parseSvgFile filename fileContent =-  parseXMLDoc fileContent >>= unparseDocument filename---- | Save a svg Document on a file on disk.-saveXmlFile :: FilePath -> Document -> IO ()-saveXmlFile filePath =-    writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument--cssDeclApplyer :: DrawAttributes -> CssDeclaration-               -> DrawAttributes-cssDeclApplyer value (CssDeclaration txt elems) =-   case lookup txt cssUpdaters of-     Nothing -> value-     Just f -> f value elems-  where-    cssUpdaters = [(T.pack $ _attributeName n, u) |-                            (n, u) <- drawAttributesList]---- | Rewrite a SVG Tree using some CSS rules.------ This action will propagate the definition of the--- css directly in each matched element.-cssApply :: [CssRule] -> Tree -> Tree-cssApply rules = zipTree go where-  go [] = None-  go ([]:_) = None-  go context@((t:_):_) = t & drawAttr .~ attr'-   where-     matchingDeclarations =-         findMatchingDeclarations rules context-     attr = view drawAttr t-     attr' = foldl' cssDeclApplyer attr matchingDeclarations---- | For every 'use' tag, try to resolve the geometry associated--- with it and place it in the scene Tree. It is important to--- resolve the 'use' tag before applying the CSS rules, as some--- rules may apply some elements matching the children of "use".-resolveUses :: Document -> Document-resolveUses doc =-  doc { _elements = mapTree fetchUses <$> _elements doc }-  where-    fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo-    fetchUses a = a--    search nfo = maybe Nothing geometryExtract found where-      found = M.lookup (_useName nfo) $ _definitions doc--    geometryExtract c = case c of-      ElementLinearGradient _ -> Nothing-      ElementRadialGradient _ -> Nothing-      ElementMeshGradient _ -> Nothing-      ElementMask _ -> Nothing-      ElementClipPath _ -> Nothing-      ElementGeometry t -> Just t-      ElementPattern _ -> Nothing-      ElementMarker _ -> Nothing---- | Rewrite the document by applying the CSS rules embedded--- inside it.-applyCSSRules :: Document -> Document-applyCSSRules doc = doc-    { _elements = cssApply (_styleRules doc) <$> _elements doc }-+{-# LANGUAGE CPP #-}
+-- | Module providing basic input/output for the SVG document,
+-- for document building, please refer to Graphics.Svg.Types.
+module Graphics.Svg ( -- * Saving/Loading functions
+                      loadSvgFile
+                    , parseSvgFile
+                    , xmlOfDocument
+                    , saveXmlFile
+
+                      -- * Manipulation functions
+                    , cssApply
+                    , cssRulesOfText
+                    , applyCSSRules
+                    , resolveUses
+
+                      -- * Type definitions
+                    , module Graphics.Svg.Types
+                    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>) )
+#endif
+
+import Data.List( foldl' )
+import qualified Data.ByteString as B
+import qualified Data.Map as M
+import qualified Data.Text as T
+import Text.XML.Light.Input( parseXMLDoc )
+import Text.XML.Light.Output( ppcTopElement, prettyConfigPP )
+import Control.Lens
+
+import Graphics.Svg.Types
+import Graphics.Svg.CssTypes
+import Graphics.Svg.CssParser( cssRulesOfText )
+import Graphics.Svg.XmlParser
+
+{-import Graphics.Svg.CssParser-}
+
+-- | Try to load an svg file on disc and parse it as
+-- a SVG Document.
+loadSvgFile :: FilePath -> IO (Maybe Document)
+loadSvgFile filename =
+  parseSvgFile filename <$> B.readFile filename
+
+-- | Parse an in-memory SVG file
+parseSvgFile :: FilePath    -- ^ Source path/URL of the document, used
+                            -- to resolve relative links.
+             -> B.ByteString
+             -> Maybe Document
+parseSvgFile filename fileContent =
+  parseXMLDoc fileContent >>= unparseDocument filename
+
+-- | Save a svg Document on a file on disk.
+saveXmlFile :: FilePath -> Document -> IO ()
+saveXmlFile filePath =
+    writeFile filePath . ppcTopElement prettyConfigPP . xmlOfDocument
+
+cssDeclApplyer :: DrawAttributes -> CssDeclaration
+               -> DrawAttributes
+cssDeclApplyer value (CssDeclaration txt elems) =
+   case lookup txt cssUpdaters of
+     Nothing -> value
+     Just f -> f value elems
+  where
+    cssUpdaters = [(T.pack $ _attributeName n, u) |
+                            (n, u) <- drawAttributesList]
+
+-- | Rewrite a SVG Tree using some CSS rules.
+--
+-- This action will propagate the definition of the
+-- css directly in each matched element.
+cssApply :: [CssRule] -> Tree -> Tree
+cssApply rules = zipTree go where
+  go [] = None
+  go ([]:_) = None
+  go context@((t:_):_) = t & drawAttr .~ attr'
+   where
+     matchingDeclarations =
+         findMatchingDeclarations rules context
+     attr = view drawAttr t
+     attr' = foldl' cssDeclApplyer attr matchingDeclarations
+
+-- | For every 'use' tag, try to resolve the geometry associated
+-- with it and place it in the scene Tree. It is important to
+-- resolve the 'use' tag before applying the CSS rules, as some
+-- rules may apply some elements matching the children of "use".
+resolveUses :: Document -> Document
+resolveUses doc =
+  doc { _elements = mapTree fetchUses <$> _elements doc }
+  where
+    fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo
+    fetchUses a = a
+
+    search nfo = maybe Nothing geometryExtract found where
+      found = M.lookup (_useName nfo) $ _definitions doc
+
+    geometryExtract c = case c of
+      ElementLinearGradient _ -> Nothing
+      ElementRadialGradient _ -> Nothing
+      ElementMeshGradient _ -> Nothing
+      ElementMask _ -> Nothing
+      ElementClipPath _ -> Nothing
+      ElementGeometry t -> Just t
+      ElementPattern _ -> Nothing
+      ElementMarker _ -> Nothing
+
+-- | Rewrite the document by applying the CSS rules embedded
+-- inside it.
+applyCSSRules :: Document -> Document
+applyCSSRules doc = doc
+    { _elements = cssApply (_styleRules doc) <$> _elements doc }
+

@@ -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,260 +1,264 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Graphics.Svg.PathParser( transformParser-                              , command-                              , pathParser-                              , viewBoxParser-                              , pointData-                              , gradientCommand-                              , serializePoints-                              , serializeCommand-                              , serializeGradientCommand -                              , serializeCommands-                              , serializeViewBox-                              ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) )-#endif--import Control.Applicative( (<|>) )-import Data.Scientific( toRealFloat )-import Data.Attoparsec.Text-    ( Parser-    , scientific-    , string-    , skipSpace-    , char-    , many1-    )-import Data.Attoparsec.Combinator( option-                                 , sepBy-                                 , sepBy1 )--import Linear hiding ( angle, point )-import Graphics.Svg.Types-import qualified Data.Text as T-import Text.Printf( printf )--num :: Parser Double-num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)-  where doubleNumber :: Parser Double-        doubleNumber = toRealFloat <$> scientific--        plusMinus = negate <$ string "-" <*> doubleNumber-                 <|> string "+" *> doubleNumber-                 <|> doubleNumber--viewBoxParser :: Parser (Double, Double, Double, Double)-viewBoxParser = (,,,)-       <$> iParse <*> iParse <*> iParse <*> iParse-  where-    iParse = num <* skipSpace--serializeViewBox :: (Double, Double, Double, Double) -> String-serializeViewBox (a, b, c, d) = printf "%g %g %g %g" a b c d--commaWsp :: Parser ()-commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace--point :: Parser RPoint-point = V2 <$> num <* commaWsp <*> num--pointData :: Parser [RPoint]-pointData = point `sepBy` commaWsp--pathParser :: Parser [PathCommand]-pathParser = skipSpace *> many1 command--command :: Parser PathCommand-command =  (MoveTo OriginAbsolute <$ string "M" <*> pointList)-       <|> (MoveTo OriginRelative <$ string "m" <*> pointList)-       <|> (LineTo OriginAbsolute <$ string "L" <*> pointList)-       <|> (LineTo OriginRelative <$ string "l" <*> pointList)-       <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList)-       <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList)-       <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList)-       <|> (VerticalTo OriginRelative <$ string "v" <*> coordList)-       <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs)-       <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs)-       <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList)-       <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList)-       <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList)-       <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList)-       <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList)-       <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList)-       <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs)-       <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs)-       <|> (EndPath <$ string "Z" <* commaWsp)-       <|> (EndPath <$ string "z" <* commaWsp)-    where pointList = point `sepBy1` commaWsp-          pointPair = (,) <$> point <* commaWsp <*> point-          pointPairList = pointPair `sepBy1` commaWsp-          coordList = num `sepBy1` commaWsp-          curveToArgs = (,,) <$> (point <* commaWsp)-                             <*> (point <* commaWsp)-                             <*> point-          manyComma a = a `sepBy1` commaWsp--          numComma = num <* commaWsp-          ellipticalArgs = (,,,,,) <$> numComma-                                   <*> numComma-                                   <*> numComma-                                   <*> (fmap (/= 0) numComma)-                                   <*> (fmap (/= 0) numComma)-                                   <*> point--serializePoint :: RPoint -> String-serializePoint (V2 x y) = printf "%g,%g" x y--serializePoints :: [RPoint] -> String-serializePoints = unwords . fmap serializePoint--serializeCoords :: [Coord] -> String-serializeCoords = unwords . fmap (printf "%g")--serializePointPair :: (RPoint, RPoint) -> String-serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b--serializePointPairs :: [(RPoint, RPoint)] -> String-serializePointPairs = unwords . fmap serializePointPair--serializePointTriplet :: (RPoint, RPoint, RPoint) -> String-serializePointTriplet (a, b, c) =-    serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c--serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String-serializePointTriplets = unwords . fmap serializePointTriplet--serializeCommands :: [PathCommand] -> String-serializeCommands = unwords . fmap serializeCommand--serializeCommand :: PathCommand -> String-serializeCommand p = case p of-  MoveTo OriginAbsolute points -> "M" ++ serializePoints points-  MoveTo OriginRelative points -> "m" ++ serializePoints points-  LineTo OriginAbsolute points -> "L" ++ serializePoints points-  LineTo OriginRelative points -> "l" ++ serializePoints points--  HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords-  HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords-  VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords-  VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords--  CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets-  CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets-  SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs-  SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs-  QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs-  QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs-  SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points-  SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points-  EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args-  EllipticalArc OriginRelative args -> "a" ++ serializeArgs args-  EndPath -> "Z"-  where-    serializeArg (a, b, c, d, e, V2 x y) =-        printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y-    serializeArgs = unwords . fmap serializeArg----transformParser :: Parser Transformation-transformParser = matrixParser-               <|> translationParser-               <|> scaleParser-               <|> rotateParser-               <|> skewYParser-               <|> skewXParser--functionParser :: T.Text -> Parser [Double]-functionParser funcName =-    string funcName *> skipSpace-                    *> char '(' *> skipSpace-                    *> num `sepBy1` commaWsp-                    <* skipSpace <* char ')' <* skipSpace--translationParser :: Parser Transformation-translationParser = do-  args <- functionParser "translate"-  return $ case args of-    [x] -> Translate x 0-    [x, y] -> Translate x y-    _ -> TransformUnknown--skewXParser :: Parser Transformation-skewXParser = do-  args <- functionParser "skewX"-  return $ case args of-    [x] -> SkewX x-    _ -> TransformUnknown--skewYParser :: Parser Transformation-skewYParser = do-  args <- functionParser "skewY"-  return $ case args of-    [x] -> SkewY x-    _ -> TransformUnknown---scaleParser :: Parser Transformation-scaleParser = do-  args <- functionParser "scale"-  return $ case args of-    [x] -> Scale x Nothing-    [x, y] -> Scale x (Just y)-    _ -> TransformUnknown--matrixParser :: Parser Transformation-matrixParser = do-  args <- functionParser "matrix"-  return $ case args of-    [a, b, c, d, e, f] ->-        TransformMatrix a b c d e f-    _ -> TransformUnknown--rotateParser :: Parser Transformation-rotateParser = do-  args <- functionParser "rotate"-  return $ case args of-    [angle] -> Rotate angle Nothing-    [angle, x, y] -> Rotate angle $ Just (x, y)-    _ -> TransformUnknown-{--rotate(<rotate-angle> [<cx> <cy>]), which specifies a rotation by <rotate-angle> degrees about a given point.--If optional parameters <cx> and <cy> are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0].--If optional parameters <cx> and <cy> are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(<cx>, <cy>) rotate(<rotate-angle>) translate(-<cx>, -<cy>).--skewX(<skew-angle>), which specifies a skew transformation along the x-axis.--skewY(<skew-angle>), which specifies a skew transformation along the y-axis.-    -}-gradientCommand :: Parser GradientPathCommand-gradientCommand = -        (GLine OriginAbsolute <$> (string "L" *> mayPoint))-    <|> (GLine OriginRelative <$> (string "l" *> mayPoint))-    <|> (string "C" *> curveToArgs OriginAbsolute)-    <|> (string "c" *> curveToArgs OriginRelative)-    <|> (GClose <$ string "Z")-  where -    mayPoint = option Nothing $ Just <$> point-    curveToArgs o =-        GCurve o <$> (point <* commaWsp)-                 <*> (point <* commaWsp)-                 <*> mayPoint--serializeGradientCommand :: GradientPathCommand -> String-serializeGradientCommand p = case p of-  GLine OriginAbsolute points -> "L" ++ smp points-  GLine OriginRelative points -> "l" ++ smp points-  GClose -> "Z"--  GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c-  GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c-  where-    sp = serializePoint-    smp Nothing = ""-    smp (Just pp) = serializePoint pp-+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+module Graphics.Svg.PathParser( transformParser
+                              , command
+                              , pathParser
+                              , viewBoxParser
+                              , pointData
+                              , gradientCommand
+                              , serializePoints
+                              , serializeCommand
+                              , serializeGradientCommand
+                              , serializeCommands
+                              , serializeViewBox
+                              ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<*), (*>), (<$>), (<$) )
+#endif
+
+import Control.Applicative( (<|>) )
+import Data.Scientific( toRealFloat )
+import Data.Attoparsec.Text
+    ( Parser
+    , scientific
+    , string
+    , skipSpace
+    , char
+    , many1
+    , digit
+    , parseOnly
+    )
+import Data.Attoparsec.Combinator( option
+                                 , sepBy
+                                 , sepBy1 )
+
+import Linear hiding ( angle, point )
+import Graphics.Svg.Types
+import qualified Data.Text as T
+import Text.Printf( printf )
+
+num :: Parser Double
+num = realToFrac <$> (skipSpace *> plusMinus <* skipSpace)
+  where doubleNumber :: Parser Double
+        doubleNumber = toRealFloat <$> scientific <|> shorthand
+
+        plusMinus = negate <$ string "-" <*> doubleNumber
+                 <|> string "+" *> doubleNumber
+                 <|> doubleNumber
+
+        shorthand = process' <$> (string "." *> many1 digit)
+        process' = either (const 0) id . parseOnly doubleNumber . T.pack . (++) "0."
+
+viewBoxParser :: Parser (Double, Double, Double, Double)
+viewBoxParser = (,,,)
+       <$> iParse <*> iParse <*> iParse <*> iParse
+  where
+    iParse = num <* skipSpace
+
+serializeViewBox :: (Double, Double, Double, Double) -> String
+serializeViewBox (a, b, c, d) = printf "%g %g %g %g" a b c d
+
+commaWsp :: Parser ()
+commaWsp = skipSpace *> option () (string "," *> return ()) <* skipSpace
+
+point :: Parser RPoint
+point = V2 <$> num <* commaWsp <*> num
+
+pointData :: Parser [RPoint]
+pointData = point `sepBy` commaWsp
+
+pathParser :: Parser [PathCommand]
+pathParser = skipSpace *> many1 command
+
+command :: Parser PathCommand
+command =  (MoveTo OriginAbsolute <$ string "M" <*> pointList)
+       <|> (MoveTo OriginRelative <$ string "m" <*> pointList)
+       <|> (LineTo OriginAbsolute <$ string "L" <*> pointList)
+       <|> (LineTo OriginRelative <$ string "l" <*> pointList)
+       <|> (HorizontalTo OriginAbsolute <$ string "H" <*> coordList)
+       <|> (HorizontalTo OriginRelative <$ string "h" <*> coordList)
+       <|> (VerticalTo OriginAbsolute <$ string "V" <*> coordList)
+       <|> (VerticalTo OriginRelative <$ string "v" <*> coordList)
+       <|> (CurveTo OriginAbsolute <$ string "C" <*> manyComma curveToArgs)
+       <|> (CurveTo OriginRelative <$ string "c" <*> manyComma curveToArgs)
+       <|> (SmoothCurveTo OriginAbsolute <$ string "S" <*> pointPairList)
+       <|> (SmoothCurveTo OriginRelative <$ string "s" <*> pointPairList)
+       <|> (QuadraticBezier OriginAbsolute <$ string "Q" <*> pointPairList)
+       <|> (QuadraticBezier OriginRelative <$ string "q" <*> pointPairList)
+       <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ string "T" <*> pointList)
+       <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ string "t" <*> pointList)
+       <|> (EllipticalArc OriginAbsolute <$ string "A" <*> manyComma ellipticalArgs)
+       <|> (EllipticalArc OriginRelative <$ string "a" <*> manyComma ellipticalArgs)
+       <|> (EndPath <$ string "Z" <* commaWsp)
+       <|> (EndPath <$ string "z" <* commaWsp)
+    where pointList = point `sepBy1` commaWsp
+          pointPair = (,) <$> point <* commaWsp <*> point
+          pointPairList = pointPair `sepBy1` commaWsp
+          coordList = num `sepBy1` commaWsp
+          curveToArgs = (,,) <$> (point <* commaWsp)
+                             <*> (point <* commaWsp)
+                             <*> point
+          manyComma a = a `sepBy1` commaWsp
+
+          numComma = num <* commaWsp
+          ellipticalArgs = (,,,,,) <$> numComma
+                                   <*> numComma
+                                   <*> numComma
+                                   <*> (fmap (/= 0) numComma)
+                                   <*> (fmap (/= 0) numComma)
+                                   <*> point
+
+serializePoint :: RPoint -> String
+serializePoint (V2 x y) = printf "%g,%g" x y
+
+serializePoints :: [RPoint] -> String
+serializePoints = unwords . fmap serializePoint
+
+serializeCoords :: [Coord] -> String
+serializeCoords = unwords . fmap (printf "%g")
+
+serializePointPair :: (RPoint, RPoint) -> String
+serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b
+
+serializePointPairs :: [(RPoint, RPoint)] -> String
+serializePointPairs = unwords . fmap serializePointPair
+
+serializePointTriplet :: (RPoint, RPoint, RPoint) -> String
+serializePointTriplet (a, b, c) =
+    serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c
+
+serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String
+serializePointTriplets = unwords . fmap serializePointTriplet
+
+serializeCommands :: [PathCommand] -> String
+serializeCommands = unwords . fmap serializeCommand
+
+serializeCommand :: PathCommand -> String
+serializeCommand p = case p of
+  MoveTo OriginAbsolute points -> "M" ++ serializePoints points
+  MoveTo OriginRelative points -> "m" ++ serializePoints points
+  LineTo OriginAbsolute points -> "L" ++ serializePoints points
+  LineTo OriginRelative points -> "l" ++ serializePoints points
+
+  HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords
+  HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords
+  VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords
+  VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords
+
+  CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets
+  CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets
+  SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs
+  SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs
+  QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs
+  QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs
+  SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points
+  SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points
+  EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args
+  EllipticalArc OriginRelative args -> "a" ++ serializeArgs args
+  EndPath -> "Z"
+  where
+    serializeArg (a, b, c, d, e, V2 x y) =
+        printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y
+    serializeArgs = unwords . fmap serializeArg
+
+
+
+transformParser :: Parser Transformation
+transformParser = matrixParser
+               <|> translationParser
+               <|> scaleParser
+               <|> rotateParser
+               <|> skewYParser
+               <|> skewXParser
+
+functionParser :: T.Text -> Parser [Double]
+functionParser funcName =
+    string funcName *> skipSpace
+                    *> char '(' *> skipSpace
+                    *> num `sepBy1` commaWsp
+                    <* skipSpace <* char ')' <* skipSpace
+
+translationParser :: Parser Transformation
+translationParser = do
+  args <- functionParser "translate"
+  return $ case args of
+    [x] -> Translate x 0
+    [x, y] -> Translate x y
+    _ -> TransformUnknown
+
+skewXParser :: Parser Transformation
+skewXParser = do
+  args <- functionParser "skewX"
+  return $ case args of
+    [x] -> SkewX x
+    _ -> TransformUnknown
+
+skewYParser :: Parser Transformation
+skewYParser = do
+  args <- functionParser "skewY"
+  return $ case args of
+    [x] -> SkewY x
+    _ -> TransformUnknown
+
+
+scaleParser :: Parser Transformation
+scaleParser = do
+  args <- functionParser "scale"
+  return $ case args of
+    [x] -> Scale x Nothing
+    [x, y] -> Scale x (Just y)
+    _ -> TransformUnknown
+
+matrixParser :: Parser Transformation
+matrixParser = do
+  args <- functionParser "matrix"
+  return $ case args of
+    [a, b, c, d, e, f] ->
+        TransformMatrix a b c d e f
+    _ -> TransformUnknown
+
+rotateParser :: Parser Transformation
+rotateParser = do
+  args <- functionParser "rotate"
+  return $ case args of
+    [angle] -> Rotate angle Nothing
+    [angle, x, y] -> Rotate angle $ Just (x, y)
+    _ -> TransformUnknown
+{-
+rotate(<rotate-angle> [<cx> <cy>]), which specifies a rotation by <rotate-angle> degrees about a given point.
+
+If optional parameters <cx> and <cy> are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0].
+
+If optional parameters <cx> and <cy> are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(<cx>, <cy>) rotate(<rotate-angle>) translate(-<cx>, -<cy>).
+
+skewX(<skew-angle>), which specifies a skew transformation along the x-axis.
+
+skewY(<skew-angle>), which specifies a skew transformation along the y-axis.
+    -}
+gradientCommand :: Parser GradientPathCommand
+gradientCommand =
+        (GLine OriginAbsolute <$> (string "L" *> mayPoint))
+    <|> (GLine OriginRelative <$> (string "l" *> mayPoint))
+    <|> (string "C" *> curveToArgs OriginAbsolute)
+    <|> (string "c" *> curveToArgs OriginRelative)
+    <|> (GClose <$ string "Z")
+  where
+    mayPoint = option Nothing $ Just <$> point
+    curveToArgs o =
+        GCurve o <$> (point <* commaWsp)
+                 <*> (point <* commaWsp)
+                 <*> mayPoint
+
+serializeGradientCommand :: GradientPathCommand -> String
+serializeGradientCommand p = case p of
+  GLine OriginAbsolute points -> "L" ++ smp points
+  GLine OriginRelative points -> "l" ++ smp points
+  GClose -> "Z"
+
+  GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c
+  GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c
+  where
+    sp = serializePoint
+    smp Nothing = ""
+    smp (Just pp) = serializePoint pp

@@ -207,7 +207,7 @@ 
 import Text.Printf
 
--- | Basic coordiante type.
+-- | Basic coordinate type.
 type Coord = Double
 
 -- | Real Point, fully determined and not

@@ -1,5 +1,5 @@ name:                svg-tree
-version:             0.6.2.2
+version:             0.6.2.3
 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.2
+    Tag:       v0.6.2.3
 
 library
   hs-source-dirs: src
@@ -38,10 +38,10 @@   exposed-modules: Graphics.Svg
                  , Graphics.Svg.CssTypes
                  , Graphics.Svg.Types
+                 , Graphics.Svg.PathParser
 
   other-modules: Graphics.Svg.NamedColors
                , Graphics.Svg.XmlParser
-               , Graphics.Svg.PathParser
                , Graphics.Svg.CssParser
                , Graphics.Svg.ColorParser
 
@@ -51,7 +51,7 @@     -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8
     build-depends: fail == 4.9.*, semigroups == 0.18.*
 
-  build-depends: base >= 4.5 && < 5
+  build-depends: base >= 4.5 && < 6
                , JuicyPixels >= 3.2
                , attoparsec >= 0.12
                , scientific >= 0.3