svg-tree 0.3.2 → 0.3.2.2
raw patch · 5 files changed
+78/−50 lines, 5 files
Files
- changelog +6/−0
- src/Graphics/Svg/PathParser.hs +4/−4
- src/Graphics/Svg/Types.hs +18/−7
- src/Graphics/Svg/XmlParser.hs +48/−37
- svg-tree.cabal +2/−2
changelog view
@@ -1,5 +1,11 @@ -*-change-log-*- +V0.3.2.2 February 2016+ * Fix: Bad serialization of some None constructors.++v0.3.2.1 October 2015+ * Fix: Don't add '#' for <img> serialization+ v0.3.2 August 2015 * Fix: allow compilation with GHC 7.4
src/Graphics/Svg/PathParser.hs view
@@ -41,14 +41,14 @@ <|> string "+" *> doubleNumber <|> doubleNumber -viewBoxParser :: Parser (Int, Int, Int, Int)+viewBoxParser :: Parser (Double, Double, Double, Double) viewBoxParser = (,,,) <$> iParse <*> iParse <*> iParse <*> iParse where- iParse = floor <$> num <* skipSpace+ iParse = num <* skipSpace -serializeViewBox :: (Int, Int, Int, Int) -> String-serializeViewBox (a, b, c, d) = printf "%d %d %d %d" a b c d+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
src/Graphics/Svg/Types.hs view
@@ -123,6 +123,7 @@ -- * Marker definition , Marker( .. )+ , Overflow( .. ) , MarkerOrientation( .. ) , MarkerUnit( .. ) , HasMarker( .. )@@ -600,7 +601,7 @@ -- inside the `<g>` tag. , _groupChildren :: ![a] -- | Mapped to the attribute `viewBox`- , _groupViewBox :: !(Maybe (Int, Int, Int, Int))+ , _groupViewBox :: !(Maybe (Double, Double, Double, Double)) } deriving (Eq, Show) @@ -927,6 +928,13 @@ | MarkerUnitUserSpaceOnUse -- ^ Value `userSpaceOnUse` deriving (Eq, Show) +-- | Define the content of the `markerUnits` attribute+-- on the Marker.+data Overflow+ = OverflowVisible -- ^ Value `visible`+ | OverflowHidden -- ^ Value `hidden`+ deriving (Eq, Show)+ -- | Define the `<marker>` tag. data Marker = Marker { -- | Draw attributes of the marker.@@ -945,8 +953,10 @@ -- | Map the `markerUnits` attribute. , _markerUnits :: Maybe MarkerUnit -- | Optional viewbox- , _markerViewBox :: !(Maybe (Int, Int, Int, Int))+ , _markerViewBox :: !(Maybe (Double, Double, Double, Double)) -- | Elements defining the marker.+ , _markerOverflow :: !(Maybe Overflow)+ -- | Elements defining the marker. , _markerElements :: [Tree] } deriving (Eq, Show)@@ -966,6 +976,7 @@ , _markerOrient = Nothing -- MarkerOrientation , _markerUnits = Nothing -- MarkerUnitStrokeWidth , _markerViewBox = Nothing+ , _markerOverflow = Nothing , _markerElements = mempty } @@ -1289,7 +1300,7 @@ { -- | Pattern drawing attributes. _patternDrawAttributes :: DrawAttributes -- | Possible `viewBox`.- , _patternViewBox :: Maybe (Int, Int, Int, Int)+ , _patternViewBox :: Maybe (Double, Double, Double, Double) -- | Width of the pattern tile, mapped to the -- `width` attribute , _patternWidth :: Number@@ -1340,7 +1351,7 @@ -- | Represent a full svg document with style, -- geometry and named elements. data Document = Document- { _viewBox :: Maybe (Int, Int, Int, Int)+ { _viewBox :: Maybe (Double, Double, Double, Double) , _width :: Maybe Number , _height :: Maybe Number , _elements :: [Tree]@@ -1363,8 +1374,8 @@ } = (floor $ dx * pw, floor $ dy * ph) where- dx = fromIntegral . abs $ x2 - x1- dy = fromIntegral . abs $ y2 - y1+ dx = abs $ x2 - x1+ dy = abs $ y2 - y1 documentSize _ Document { _width = Just (Num w) , _height = Just (Num h) } = (floor w, floor h) documentSize dpi doc@(Document { _width = Just w@@ -1373,7 +1384,7 @@ { _width = Just $ toUserUnit dpi w , _height = Just $ toUserUnit dpi h } documentSize _ Document { _viewBox = Just (x1, y1, x2, y2) } =- (abs $ x2 - x1, abs $ y2 - y1)+ (floor . abs $ x2 - x1, floor . abs $ y2 - y1) documentSize _ _ = (1, 1) mayMerge :: Monoid a => Maybe a -> Maybe a -> Maybe a
src/Graphics/Svg/XmlParser.hs view
@@ -19,7 +19,7 @@ #endif #if !MIN_VERSION_base(4,8,0)-import Control.Applicative( pure, (<$>), (<$) )+import Control.Applicative( pure, (<$>), (<$), (<*>) ) import Data.Foldable( foldMap ) import Data.Monoid( mempty ) #endif@@ -222,6 +222,16 @@ MarkerUnitStrokeWidth -> "strokeWidth" MarkerUnitUserSpaceOnUse -> "userSpaceOnUse" +instance ParseableAttribute Overflow where+ aparse s = case s of+ "visible" -> Just OverflowVisible+ "hidden" -> Just OverflowHidden+ _ -> Nothing++ aserialize u = Just $ case u of+ OverflowVisible -> "visible"+ OverflowHidden -> "hidden"+ instance ParseableAttribute MarkerOrientation where aparse s = case (s, readMaybe s) of ("auto", _) -> Just OrientationAuto@@ -232,7 +242,7 @@ OrientationAuto -> "auto" OrientationAngle f -> show f -instance ParseableAttribute (Int, Int, Int, Int) where+instance ParseableAttribute (Double, Double, Double, Double) where aparse = parse viewBoxParser aserialize = Just . serializeViewBox @@ -291,18 +301,19 @@ xmlTagName :: treeNode -> String attributes :: [SvgAttributeLens treeNode] - serializeTreeNode :: treeNode -> X.Element+ serializeTreeNode :: treeNode -> Maybe X.Element setChildren :: X.Element -> [X.Content] -> X.Element setChildren xNode children = xNode { X.elContent = children } -updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> X.Element -> X.Element-updateWithAccessor accessor node xNode =- setChildren xNode $ X.Elem . serializeTreeNode <$> accessor node+updateWithAccessor :: XMLUpdatable b => (a -> [b]) -> a -> Maybe X.Element -> Maybe X.Element+updateWithAccessor _ _ Nothing = Nothing+updateWithAccessor accessor node (Just xNode) =+ Just . setChildren xNode . fmap X.Elem . catMaybes $ serializeTreeNode <$> accessor node -genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> X.Element+genericSerializeNode :: (XMLUpdatable treeNode) => treeNode -> Maybe X.Element genericSerializeNode node =- X.unode (xmlTagName node) $ concatMap generateAttribute attributes+ Just . X.unode (xmlTagName node) $ concatMap generateAttribute attributes where generateAttribute attr = case _attributeSerializer attr node of Nothing -> []@@ -323,8 +334,8 @@ thisXml { X.elAttribs = X.elAttribs otherXml ++ X.elAttribs thisXml } genericSerializeWithDrawAttr :: (XMLUpdatable treeNode, WithDrawAttributes treeNode)- => treeNode -> X.Element-genericSerializeWithDrawAttr node = mergeAttributes thisXml drawAttrNode where+ => treeNode -> Maybe X.Element+genericSerializeWithDrawAttr node = mergeAttributes <$> thisXml <*> drawAttrNode where thisXml = genericSerializeNode node drawAttrNode = genericSerializeNode $ node ^. drawAttr @@ -548,7 +559,7 @@ ,"height" `parseIn` imageHeight ,"x" `parseIn` (imageCornerUpperLeft._1) ,"y" `parseIn` (imageCornerUpperLeft._2)- ,parserSetter "href" imageHref (Just . dropSharp) (Just . ('#':))+ ,parserSetter "href" imageHref (Just . dropSharp) Just ] instance XMLUpdatable Line where@@ -637,7 +648,7 @@ xmlTagName _ = "TREE" attributes = [] serializeTreeNode e = case e of- None -> X.blank_element+ None -> Nothing UseTree u _ -> serializeTreeNode u GroupTree g -> serializeTreeNode g SymbolTree s -> serializeTreeNode s@@ -650,11 +661,11 @@ RectangleTree r -> serializeTreeNode r TextTree Nothing t -> serializeTreeNode t ImageTree i -> serializeTreeNode i- TextTree (Just p) t ->- setChildren textNode [X.Elem . setChildren pathNode $ X.elContent textNode]- where- textNode = serializeTreeNode t- pathNode = serializeTreeNode p+ TextTree (Just p) t -> do+ textNode <- serializeTreeNode t+ pathNode <- serializeTreeNode p+ let sub = [X.Elem . setChildren pathNode $ X.elContent textNode]+ return $ setChildren textNode sub isNotNone :: Tree -> Bool@@ -770,21 +781,28 @@ ,"patternUnits" `parseIn` markerUnits ,"orient" `parseIn` markerOrient ,"viewBox" `parseIn` markerViewBox+ ,"overflow" `parseIn` markerOverflow ] -serializeText :: Text -> X.Element-serializeText topText = topNode { X.elName = X.unqual "text" } where+serializeText :: Text -> Maybe X.Element+serializeText topText = namedNode where+ namedNode = fmap (\x -> x { X.elName = X.unqual "text" }) topNode topNode = serializeSpan $ _textRoot topText - serializeSpan tspan = setChildren (mergeAttributes info drawInfo) subContent+ serializeSpan tspan = case (info, drawInfo) of+ (Nothing, Nothing) -> Nothing+ (Just a, Nothing) -> Just $ setChildren a subContent+ (Nothing, Just b) -> Just $ setChildren b subContent+ (Just a, Just b) -> + Just $ setChildren (mergeAttributes a b) subContent where info = genericSerializeNode $ _spanInfo tspan drawInfo = genericSerializeNode $ _spanDrawAttributes tspan- subContent = serializeContent <$> _spanContent tspan+ subContent = catMaybes $ serializeContent <$> _spanContent tspan - serializeContent (SpanText t) = X.Text $ X.blank_cdata { X.cdData = T.unpack t }- serializeContent (SpanTextRef _t) = X.Text $ X.blank_cdata { X.cdData = "" }- serializeContent (SpanSub sub) = X.Elem $ serializeSpan sub+ serializeContent (SpanText t) = Just . X.Text $ X.blank_cdata { X.cdData = T.unpack t }+ serializeContent (SpanTextRef _t) = Just . X.Text $ X.blank_cdata { X.cdData = "" }+ serializeContent (SpanSub sub) = X.Elem <$> serializeSpan sub unparseText :: [X.Content] -> ([TextSpanContent], Maybe TextPath) unparseText = extractResult . go True@@ -1025,28 +1043,21 @@ X.node (X.unqual "svg") (attrs, descTag ++ styleTag ++ defsTag ++ children) where attr name = X.Attr (X.unqual name)- children = [serializeTreeNode el | el <- _elements doc, isNotNone el ]+ children = catMaybes [serializeTreeNode el | el <- _elements doc] defsTag | null defs = [] | otherwise = [X.node (X.unqual "defs") defs] - defs = [elementRender k e | (k, e) <- M.assocs $ _definitions doc- , isElementNotNone e]-- isElementNotNone (ElementGeometry el) = isNotNone el- isElementNotNone _ = True+ defs = catMaybes [elementRender k e | (k, e) <- M.assocs $ _definitions doc] - elementRender k e = case e of+ elementRender k e = X.add_attr (attr "id" k) <$> case e of ElementGeometry t -> serializeTreeNode t ElementMarker m -> serializeTreeNode m ElementMask m -> serializeTreeNode m ElementClipPath c -> serializeTreeNode c- ElementPattern p ->- X.add_attr (attr "id" k) $ serializeTreeNode p- ElementLinearGradient lg ->- X.add_attr (attr "id" k) $ serializeTreeNode lg- ElementRadialGradient rg ->- X.add_attr (attr "id" k) $ serializeTreeNode rg+ ElementPattern p -> serializeTreeNode p+ ElementLinearGradient lg -> serializeTreeNode lg+ ElementRadialGradient rg -> serializeTreeNode rg docViewBox = case _viewBox doc of Nothing -> []
svg-tree.cabal view
@@ -1,5 +1,5 @@ name: svg-tree-version: 0.3.2+version: 0.3.2.2 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.3.2+ Tag: v0.3.2.2 library hs-source-dirs: src