diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/src/Graphics/Svg.hs b/src/Graphics/Svg.hs --- a/src/Graphics/Svg.hs +++ b/src/Graphics/Svg.hs @@ -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 } + diff --git a/src/Graphics/Svg/CssParser.hs b/src/Graphics/Svg/CssParser.hs --- a/src/Graphics/Svg/CssParser.hs +++ b/src/Graphics/Svg/CssParser.hs @@ -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 + diff --git a/src/Graphics/Svg/CssTypes.hs b/src/Graphics/Svg/CssTypes.hs --- a/src/Graphics/Svg/CssTypes.hs +++ b/src/Graphics/Svg/CssTypes.hs @@ -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 + diff --git a/src/Graphics/Svg/PathParser.hs b/src/Graphics/Svg/PathParser.hs --- a/src/Graphics/Svg/PathParser.hs +++ b/src/Graphics/Svg/PathParser.hs @@ -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( [ ]), which specifies a rotation by degrees about a given point. - -If optional parameters and are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0]. - -If optional parameters and are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(, ) rotate() translate(-, -). - -skewX(), which specifies a skew transformation along the x-axis. - -skewY(), which specifies a skew transformation along the y-axis. - -} -gradientCommand :: Parser GradientPathCommand -gradientCommand = - (GLine OriginAbsolute <$> (string "L" *> mayPoint)) - <|> (GLine OriginRelative <$> (string "l" *> mayPoint)) - <|> (string "C" *> curveToArgs OriginAbsolute) - <|> (string "c" *> curveToArgs OriginRelative) - <|> (GClose <$ string "Z") - where - mayPoint = option Nothing $ Just <$> point - curveToArgs o = - GCurve o <$> (point <* commaWsp) - <*> (point <* commaWsp) - <*> mayPoint - -serializeGradientCommand :: GradientPathCommand -> String -serializeGradientCommand p = case p of - GLine OriginAbsolute points -> "L" ++ smp points - GLine OriginRelative points -> "l" ++ smp points - GClose -> "Z" - - GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c - GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c - where - sp = serializePoint - smp Nothing = "" - smp (Just pp) = serializePoint pp - +{-# 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( [ ]), which specifies a rotation by degrees about a given point. + +If optional parameters and are not supplied, the rotation is about the origin of the current user coordinate system. The operation corresponds to the matrix [cos(a) sin(a) -sin(a) cos(a) 0 0]. + +If optional parameters and are supplied, the rotation is about the point (cx, cy). The operation represents the equivalent of the following specification: translate(, ) rotate() translate(-, -). + +skewX(), which specifies a skew transformation along the x-axis. + +skewY(), which specifies a skew transformation along the y-axis. + -} +gradientCommand :: Parser GradientPathCommand +gradientCommand = + (GLine OriginAbsolute <$> (string "L" *> mayPoint)) + <|> (GLine OriginRelative <$> (string "l" *> mayPoint)) + <|> (string "C" *> curveToArgs OriginAbsolute) + <|> (string "c" *> curveToArgs OriginRelative) + <|> (GClose <$ string "Z") + where + mayPoint = option Nothing $ Just <$> point + curveToArgs o = + GCurve o <$> (point <* commaWsp) + <*> (point <* commaWsp) + <*> mayPoint + +serializeGradientCommand :: GradientPathCommand -> String +serializeGradientCommand p = case p of + GLine OriginAbsolute points -> "L" ++ smp points + GLine OriginRelative points -> "l" ++ smp points + GClose -> "Z" + + GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c + GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c + where + sp = serializePoint + smp Nothing = "" + smp (Just pp) = serializePoint pp diff --git a/src/Graphics/Svg/Types.hs b/src/Graphics/Svg/Types.hs --- a/src/Graphics/Svg/Types.hs +++ b/src/Graphics/Svg/Types.hs @@ -207,7 +207,7 @@ import Text.Printf --- | Basic coordiante type. +-- | Basic coordinate type. type Coord = Double -- | Real Point, fully determined and not diff --git a/svg-tree.cabal b/svg-tree.cabal --- a/svg-tree.cabal +++ b/svg-tree.cabal @@ -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