diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ -# Revision history for nano-svg - -## 0.1.0.0 - -* First version. +# Revision history for nano-svg + +## 0.2.0.0 + +* Breaking: collapse into three modules. `Graphics.NanoSvg.Color`, `.Number`, + `.Path`, `.Xml` and `.Internal.Parser` are gone; their value parsers live in + `Graphics.NanoSvg.Attribute`. +* Breaking: remove `documentWidth`/`documentHeight`, the `RGBA` channel + accessors, `withAlpha`, `transparent`, `Length`/`Unit` and the raw flatparse + parsers. `parseLength` now returns user units. +* Add `encodeSvg` and `svgBuilder`, which write a `Document` back out as SVG + with bytestring builders. `parseSvg` reads the result back to the same + shapes. +* `use` elements nest at most `maxUseDepth` (8) deep, so a small file cannot + expand exponentially. +* Entity decoding is linear in the attribute length, and numeric character + references no longer build an `Integer` from any number of digits. +* Look up `use` targets and named colors in maps, and share a target's + geometry across its uses. +* `0e400` and long mantissas parse as finite numbers. + +## 0.1.0.0 + +* First version. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,20 +1,20 @@ -Copyright (c) 2026 goolord - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +Copyright (c) 2026 goolord + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,68 +1,66 @@ -# nano-svg - -A fast SVG parser for Haskell. Bytes in, a flat array of shapes out. - -For geometry renderers, rasterizers and UI toolkits that need SVG icons and -static vector artwork as paths. The library parses and normalizes geometry; -the caller handles rendering and viewport mapping. - -## Quick start - -`parseSvg :: ByteString -> Either String Document` reads UTF-8 SVG directly -from a strict `ByteString`—no text-decoding step needed. - -```haskell -import Graphics.NanoSvg -import qualified Data.ByteString as BS - -main :: IO () -main = do - bytes <- BS.readFile "clock.svg" - case parseSvg bytes of - Left err -> putStrLn err - Right doc -> print (documentSize doc, length (documentShapes doc)) -``` - -A `Document` contains the viewport size, the `viewBox` and a `SmallArray` of -`Shape`s in paint order. Each shape carries its path, the `Matrix` that maps -it into the `viewBox`, and its resolved `Style`. Relative path commands, -shorthands and basic shapes become a common set of absolute path segments. -The renderer walks segments without resolving an SVG tree, style inheritance -or a transform stack. It still tracks the current point and subpath start. - -## SVG scope - -Supports paths, rectangles, circles, ellipses, lines, polylines and polygons; -groups and `use` references; fills, strokes and inline styles; and SVG -transforms. The focus is the static geometry used in icons and vector assets. - -Not supported: gradients, patterns and other paint servers; `text`; -`clipPath`, `mask` and `filter`; `marker`; CSS in a `style` element or an -external sheet, and so `class` selectors; animation; and -`preserveAspectRatio`, which is left to the renderer. - -Unknown elements are skipped along with their children. Group opacity is -multiplied into each shape rather than preserved as a compositing group. -Nested `svg` and referenced `symbol` elements do not establish viewports. - -## Modules - -The parsing modules can also be used independently for individual path, -transform, color or length values. - -| Module | Purpose | -| --- | --- | -| `Graphics.NanoSvg` | `parseSvg`, and the types re-exported | -| `Graphics.NanoSvg.Types` | the document model, on its own | -| `Graphics.NanoSvg.Xml` | the tree, entity decoding, `DOCTYPE` and prefix stripping | -| `Graphics.NanoSvg.Path` | path and transform parsing; basic shapes as segments | -| `Graphics.NanoSvg.Color` | paints, colors, the keyword table | -| `Graphics.NanoSvg.Number` | numbers, lengths, number and point lists | - -## Build - -``` -cabal build -cabal test -cabal haddock --open -``` +# nano-svg + +A fast SVG parser for Haskell. Bytes in, a flat array of shapes out. + +For geometry renderers, rasterizers and UI toolkits that need SVG icons and +static vector artwork as paths. The library parses and normalizes geometry; +the caller handles rendering and viewport mapping. + +## Quick start + +`parseSvg :: ByteString -> Either String Document` reads UTF-8 SVG directly +from a strict `ByteString`—no text-decoding step needed. + +```haskell +import Graphics.NanoSvg +import qualified Data.ByteString as BS + +main :: IO () +main = do + bytes <- BS.readFile "clock.svg" + case parseSvg bytes of + Left err -> putStrLn err + Right doc -> print (documentSize doc, length (documentShapes doc)) +``` + +A `Document` contains the viewport size, the `viewBox` and a `SmallArray` of +`Shape`s in paint order. Each shape carries its path, the `Matrix` that maps +it into the `viewBox`, and its resolved `Style`. Relative path commands, +shorthands and basic shapes become a common set of absolute path segments. +The renderer walks segments without resolving an SVG tree, style inheritance +or a transform stack. It still tracks the current point and subpath start. + +`encodeSvg :: Document -> ByteString` writes a document back out as SVG, one +`path` per shape; `svgBuilder` gives the same as a bytestring `Builder`. +Parsing the result gives back the same shapes. + +## SVG scope + +Supports paths, rectangles, circles, ellipses, lines, polylines and polygons; +groups and `use` references; fills, strokes and inline styles; and SVG +transforms. The focus is the static geometry used in icons and vector assets. + +Not supported: gradients, patterns and other paint servers; `text`; +`clipPath`, `mask` and `filter`; `marker`; CSS in a `style` element or an +external sheet, and so `class` selectors; animation; and +`preserveAspectRatio`, which is left to the renderer. + +Unknown elements are skipped along with their children. Group opacity is +multiplied into each shape rather than preserved as a compositing group. +Nested `svg` and referenced `symbol` elements do not establish viewports. + +## Modules + +| Module | Purpose | +| --- | --- | +| `Graphics.NanoSvg` | `parseSvg` and `encodeSvg`, re-exporting the two below | +| `Graphics.NanoSvg.Types` | the document model and matrix helpers | +| `Graphics.NanoSvg.Attribute` | standalone parsers for paths, transforms, colors, numbers and lengths | + +## Build + +``` +cabal build +cabal test +cabal haddock --open +``` diff --git a/lib/Graphics/NanoSvg.hs b/lib/Graphics/NanoSvg.hs --- a/lib/Graphics/NanoSvg.hs +++ b/lib/Graphics/NanoSvg.hs @@ -1,331 +1,336 @@ -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Graphics.NanoSvg --- Copyright : (c) 2026 goolord --- License : MIT --- --- Read an SVG document into a flat array of shapes. --- For geometry renderers, rasterizers and UI toolkits drawing static SVGs. --- Shapes contain absolute path segments, a transform and a resolved style. --- Rendering and viewport mapping are left to the caller. --- --- > import Graphics.NanoSvg --- > import qualified Data.ByteString as BS --- > --- > main :: IO () --- > main = do --- > bytes <- BS.readFile "clock.svg" --- > case parseSvg bytes of --- > Left err -> putStrLn err --- > Right doc -> print (documentSize doc, length (documentShapes doc)) --- --- = Supported SVG --- --- The elements @svg@, @g@, @a@, @switch@, @use@, @path@, @rect@, @circle@, --- @ellipse@, @line@, @polyline@ and @polygon@, with @use@ resolved against --- @defs@ and @symbol@ by @id@. --- --- The presentation properties @fill@, @stroke@, @stroke-width@, --- @stroke-linecap@, @stroke-linejoin@, @stroke-miterlimit@, @fill-rule@, --- @opacity@, @fill-opacity@, @stroke-opacity@, @display@ and @visibility@, --- written either as attributes or in a @style@ attribute, which wins. --- --- @transform@ in all six of its forms, colors in all of theirs (see --- "Graphics.NanoSvg.Color"), and lengths in absolute units (see --- "Graphics.NanoSvg.Number"). --- --- = Limitations --- --- Gradients, patterns and other paint servers; @text@; @clipPath@, @mask@ --- and @filter@; @marker@; CSS in a @style@ element or an external sheet, --- and so @class@ selectors; and animation are not supported. --- The renderer must handle @preserveAspectRatio@. --- --- Unknown elements and their children are skipped. Group opacity is --- multiplied into each shape, not preserved as a compositing group. --- Nested @svg@ and referenced @symbol@ elements do not establish viewports. -module Graphics.NanoSvg - ( -- * Parsing - parseSvg - - -- * Documents - , Document (..) - , documentWidth - , documentHeight - - -- * Shapes - , Shape (..) - , Segment (..) - , Style (..) - , defaultStyle - - -- * Paint - , Paint (..) - , FillRule (..) - , LineCap (..) - , LineJoin (..) - , RGBA (..) - , rgba - , rgbaR - , rgbaG - , rgbaB - , rgbaA - , withAlpha - , black - , transparent - - -- * Geometry - , Point (..) - , Box (..) - , Matrix (..) - , identity - , multiply - , transformPoint - , averageScale - - -- * Standalone parsers - -- $pieces - ) -where - -import Data.Bits (xor) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as BC -import Data.List (find) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) -import Data.Primitive.SmallArray (smallArrayFromList) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Word (Word64) -import Graphics.NanoSvg.Color (parsePaint) -import Graphics.NanoSvg.Internal.Parser (clamp01, lowercase, strip) -import Graphics.NanoSvg.Number (Length (..), Unit (..), parseLength, parseNumberList, parsePointList, parseUserUnits, toUserUnits) -import Graphics.NanoSvg.Path -import Graphics.NanoSvg.Types -import Graphics.NanoSvg.Xml - --- $pieces --- --- These modules can be used independently: --- "Graphics.NanoSvg.Xml" for the tree, "Graphics.NanoSvg.Path" for @d@ and --- @transform@, "Graphics.NanoSvg.Color" for paints and --- "Graphics.NanoSvg.Number" for numbers and lengths. - --------------------------------------------------------------------------------- --- Parsing --------------------------------------------------------------------------------- - --- | Parse UTF-8 SVG bytes. Returns 'Left' on XML parse failure or when no --- top-level @svg@ element exists. Invalid attribute values are ignored; --- malformed paths retain the segments parsed before the error. --- --- Accepts a UTF-8 byte-order mark and a DOCTYPE. No prior text decoding is --- needed. The resulting t'Document' contains values, not source-buffer slices. -parseSvg :: ByteString -> Either String Document -parseSvg src = do - elements <- parseXml src - root <- case find ((== "svg") . elementName) elements of - Just r -> Right r - Nothing -> Left "no svg element" - let (box, extent) = geometry root - shapes = smallArrayFromList (collect (identified root) Set.empty identity defaultStyle root) - pure - Document - { documentViewBox = box - , documentSize = extent - , documentShapes = shapes - , documentKey = hashBytes src - , documentMonochrome = all monochrome shapes - } - --- | Resolve the root viewBox and output size. Missing dimensions use the --- viewBox extent; without a valid viewBox, each missing dimension is 24. -geometry :: Element -> (Box, (Float, Float)) -geometry root = (box, (fromMaybe (boxW box) width, fromMaybe (boxH box) height)) - where - side k = attribute k root >>= parseUserUnits - width = side "width" - height = side "height" - box = case maybe [] parseNumberList (attribute "viewBox" root) of - [x, y, w, h] | w > 0, h > 0 -> Box x y w h - -- Default to a 24-unit extent for each unresolved dimension. - _ -> Box 0 0 (fromMaybe 24 width) (fromMaybe 24 height) - --- | Unspecified paints and @currentColor@ follow the caller's tint; one --- explicit color anywhere makes the drawing multicolored. -monochrome :: Shape -> Bool -monochrome sh = tintable (styleFill s) && tintable (styleStroke s) - where - s = shapeStyle sh - tintable = \case - Just (PaintColor _) -> False - _ -> True - --- | FNV-1a over the source, for callers that cache what they draw. -hashBytes :: ByteString -> Int -hashBytes = fromIntegral . BS.foldl' step (0xcbf29ce484222325 :: Word64) - where - step !h !w = (h `xor` fromIntegral w) * 0x100000001b3 - --------------------------------------------------------------------------------- --- The tree --------------------------------------------------------------------------------- - --- | Index all IDs, including those under @defs@. The first duplicate wins. -identified :: Element -> Map ByteString Element -identified root = - Map.fromListWith - (\_new old -> old) - [(i, el) | el <- descendants root, Just i <- [attribute "id" el]] - --- | IDs currently being expanded by @use@. Tracking active IDs stops cycles --- before branching references can cause exponential expansion. -type Open = Set ByteString - --- | The shapes an element and its descendants draw, in paint order. -collect :: - Map ByteString Element -> Open -> Matrix -> Style -> Element -> [Shape] -collect defs open outer inherited el = case elementName el of - "svg" -> drawable descend - "g" -> drawable descend - "a" -> drawable descend - -- Conditional processing attributes are ignored: use the first child - -- that produces shapes. - "switch" -> - drawable (fromMaybe [] (find (not . null) (map into (elementChildren el)))) - "use" -> drawable used - "path" -> shape (parsePath (value "d")) - "rect" -> - shape - ( rectSegments - (num "x") - (num "y") - (num "width") - (num "height") - (len "rx") - (len "ry") - ) - "circle" -> shape (circleSegments (num "cx") (num "cy") (num "r")) - "ellipse" -> shape (ellipseSegments (num "cx") (num "cy") (num "rx") (num "ry")) - "line" -> shape (lineSegments (num "x1") (num "y1") (num "x2") (num "y2")) - "polyline" -> shape (polySegments False (parsePointList (value "points"))) - "polygon" -> shape (polySegments True (parsePointList (value "points"))) - -- Skip unsupported elements and their subtrees. - _ -> [] - where - -- Inline styles follow presentation attributes so later declarations win. - properties = - [(attributeName a, attributeValue a) | a <- elementAttributes el] - <> styleProperties (value "style") - - -- Check visibility before evaluating geometry. - drawable shapes = if hidden then [] else shapes - hidden = uncurry (||) (foldl' seen (False, False) properties) - where - -- Last one wins, so a later declaration can un-hide as well as hide. - seen acc@(off, invisible) (k, v) = case k of - "display" -> (keyword v == "none", invisible) - "visibility" -> (off, keyword v `elem` ["hidden", "collapse"]) - _ -> acc - keyword = lowercase . strip - - transform = maybe outer (multiply outer . parseTransform) (attribute "transform" el) - - -- Resolve local opacity, then multiply by the ancestor product. - -- This approximates group opacity; overlapping shapes are not composited - -- as a group. - style = own {styleOpacity = styleOpacity inherited * styleOpacity own} - where - own = foldl' applyProperty inherited {styleOpacity = 1} properties - - into = collect defs open transform style - descend = concatMap into (elementChildren el) - shape segs - | hidden = [] - | null segs = [] - | otherwise = [Shape (smallArrayFromList segs) transform style] - - value k = fromMaybe "" (attribute k el) - len k = attribute k el >>= parseUserUnits - num k = fromMaybe 0 (len k) - - -- Apply the use element's offset and style to its local reference. - -- For symbol/svg targets, expand only their children; target attributes - -- and viewport mapping are skipped. - used = case reference of - Nothing -> [] - Just (key, target) - | key `Set.member` open -> [] -- Already drawing this one. - | elementName target `elem` ["symbol", "svg"] -> - concatMap (deeper key) (elementChildren target) - | otherwise -> deeper key target - where - reference = do - href <- attribute "href" el - key <- BS.stripPrefix "#" (strip href) - target <- Map.lookup key defs - pure (key, target) - deeper key = - collect - defs - (Set.insert key open) - (transform `multiply` translation (num "x") (num "y")) - style - --------------------------------------------------------------------------------- --- Presentation properties --------------------------------------------------------------------------------- - --- | Parse and clamp opacity to [0, 1]. Percentages are divided by 100; --- other accepted lengths use the same conversion as geometry attributes. -opacityValue :: ByteString -> Maybe Float -opacityValue v = - clamp01 <$> case parseLength v of - Just (Length x Percent) -> Just (x / 100) - Just l -> toUserUnits l - Nothing -> Nothing - --- | Split inline declarations at semicolons and the first colon. --- Entries without a colon are dropped. This is not a full CSS parser. -styleProperties :: ByteString -> [(ByteString, ByteString)] -styleProperties = - concatMap declaration . BC.split ';' - where - declaration d = case BC.break (== ':') d of - (k, v) - | BS.null v -> [] - | otherwise -> [(lowercase (strip k), strip (BS.drop 1 v))] - --- | Apply a supported declaration. Invalid or unsupported values, including --- @inherit@ and @url()@ paints, leave the current style unchanged. -applyProperty :: Style -> (ByteString, ByteString) -> Style -applyProperty s (k, raw) = case k of - "opacity" -> maybe s (\o -> s {styleOpacity = o}) (opacityValue v) - "fill" -> maybe s (\p -> s {styleFill = Just p}) (parsePaint v) - "stroke" -> maybe s (\p -> s {styleStroke = Just p}) (parsePaint v) - "stroke-width" -> maybe s (\w -> s {styleStrokeWidth = max 0 w}) (parseUserUnits v) - "stroke-miterlimit" -> maybe s (\l -> s {styleMiterLimit = max 1 l}) (parseUserUnits v) - "fill-opacity" -> maybe s (\o -> s {styleFillOpacity = o}) (opacityValue v) - "stroke-opacity" -> maybe s (\o -> s {styleStrokeOpacity = o}) (opacityValue v) - "stroke-linecap" -> case keyword of - "butt" -> s {styleCap = CapButt} - "round" -> s {styleCap = CapRound} - "square" -> s {styleCap = CapSquare} - _ -> s - "stroke-linejoin" -> case keyword of - "miter" -> s {styleJoin = JoinMiter} - "round" -> s {styleJoin = JoinRound} - "bevel" -> s {styleJoin = JoinBevel} - _ -> s - "fill-rule" -> case keyword of - "nonzero" -> s {styleFillRule = NonZero} - "evenodd" -> s {styleFillRule = EvenOdd} - _ -> s - _ -> s - where - v = strip raw - keyword = lowercase v +-- | +-- Module : Graphics.NanoSvg +-- Copyright : (c) 2026 goolord +-- License : MIT +-- +-- Read an SVG document into a flat array of shapes, each with absolute path +-- segments, a transform and a resolved style. Rendering and viewport mapping +-- are left to the caller. +-- +-- > case parseSvg bytes of +-- > Left err -> putStrLn err +-- > Right doc -> print (documentSize doc, length (documentShapes doc)) +-- +-- 'encodeSvg' writes a document back out as SVG, one @path@ per shape. +-- +-- = Supported SVG +-- +-- The elements @svg@, @g@, @a@, @switch@, @use@, @path@, @rect@, @circle@, +-- @ellipse@, @line@, @polyline@ and @polygon@, with @use@ resolved by @id@ +-- and nested at most 'maxUseDepth' deep. +-- The properties @fill@, @stroke@, @stroke-width@, @stroke-linecap@, +-- @stroke-linejoin@, @stroke-miterlimit@, @fill-rule@, @opacity@, +-- @fill-opacity@, @stroke-opacity@, @display@ and @visibility@, as +-- attributes or in a @style@ attribute, which wins. All @transform@ +-- functions; hex, @rgb()@, @hsl()@ and the 148 named colors; lengths in +-- absolute units at 96 per inch. +-- +-- = Limitations +-- +-- Paint servers, @text@, @clipPath@, @mask@, @filter@, @marker@, CSS +-- stylesheets and animation are not supported, and unknown elements are +-- skipped with their children. Group opacity is multiplied into each shape. +-- Nested @svg@ and @symbol@ do not establish viewports, and +-- @preserveAspectRatio@ is left to the renderer. +module Graphics.NanoSvg + ( parseSvg + , maxUseDepth + , encodeSvg + , svgBuilder + , module Graphics.NanoSvg.Types + , module Graphics.NanoSvg.Attribute + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad (join) +import Data.Bits (shiftR, xor) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Builder qualified as B +import Data.ByteString.Char8 qualified as BC +import Data.Char (chr, toLower) +import Data.Foldable (toList) +import Data.List (find, intersperse) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Primitive.SmallArray (SmallArray, smallArrayFromList) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Word (Word64, Word8) +import FlatParse.Basic qualified as F +import Graphics.NanoSvg.Attribute +import Graphics.NanoSvg.Types +import Text.XML.Hexml qualified as X + +-- | Parse UTF-8 SVG bytes. Fails on malformed XML or without an @svg@ +-- element. Invalid attribute values are ignored, and malformed paths keep +-- the segments before the error. +parseSvg :: ByteString -> Either String Document +parseSvg src = do + roots <- either (Left . BC.unpack) (Right . nodes) (X.parse (withoutDoctype src)) + root <- maybe (Left "no svg element") Right (find ((== "svg") . tag) roots) + let side k = attr k root >>= parseLength + box = case maybe [] parseNumberList (attr "viewBox" root) of + [x, y, w, h] | w > 0, h > 0 -> Box x y w h + _ -> Box 0 0 (fromMaybe 24 (side "width")) (fromMaybe 24 (side "height")) + -- The first element with an id wins. + ids = Map.fromListWith (\_ first -> first) [(i, el) | el <- descendants root, Just i <- [attr "id" el]] + shapes = collect ids Set.empty identity defaultStyle root [] + pure + Document + { documentViewBox = box + , documentSize = (fromMaybe (boxW box) (side "width"), fromMaybe (boxH box) (side "height")) + , documentShapes = smallArrayFromList shapes + , documentKey = fromIntegral (BS.foldl' (\h w -> (h `xor` fromIntegral w) * 0x100000001b3) (0xcbf29ce484222325 :: Word64) src) + , documentMonochrome = null [() | Shape _ _ s <- shapes, Just (PaintColor _) <- [styleFill s, styleStroke s]] + } + +-- | Prepend the shapes an element draws. @open@ holds the @use@ targets +-- being expanded, to cut reference cycles and bound nesting. +collect :: Map ByteString Element -> Set ByteString -> Matrix -> Style -> Element -> [Shape] -> [Shape] +collect ids open outer inherited el rest + | keyword "display" == Just "none" || keyword "visibility" `elem` [Just "hidden", Just "collapse"] = rest + | otherwise = case tag el of + t | t `elem` ["svg", "g", "a"] -> foldr into rest (kids el) + "switch" -> foldr (\kid next -> case into kid [] of [] -> next; drawn -> drawn <> rest) rest (kids el) + "use" -> case attr "href" el >>= BS.stripPrefix "#" . BC.strip of + Just key | Set.size open < maxUseDepth, Set.notMember key open, Just target <- Map.lookup key ids -> do + let draw = collect ids (Set.insert key open) (transform `multiply` translate (num el "x") (num el "y")) style + if tag target `elem` ["symbol", "svg"] then foldr draw rest (kids target) else draw target rest + _ -> rest + _ | null (geometry el) -> rest + | otherwise -> Shape (geometry el) transform style : rest + where + props = attrs el <> declarations (value "style" el) + latest = reverse props + keyword k = lower . BC.strip <$> lookup k latest + transform = maybe outer (multiply outer . parseTransform) (attr "transform" el) + own = foldl' property inherited {styleOpacity = 1} props + style = own {styleOpacity = styleOpacity inherited * styleOpacity own} + into = collect ids open transform style + +-- | How many @use@ elements may nest, counting through their targets; one +-- nested deeper draws nothing. Firefox's @svg.use-element.recursive-clone-limit@ +-- is also 8. +maxUseDepth :: Int +maxUseDepth = 8 + +-- | The segments of a basic shape or path, in its own coordinates. +segments :: Element -> [Segment] +segments el = case tag el of + "path" -> parsePath (value "d" el) + "rect" -> rect (num el "x") (num el "y") (num el "width") (num el "height") (len el "rx") (len el "ry") + "circle" -> ellipse (num el "cx") (num el "cy") (num el "r") (num el "r") + "ellipse" -> ellipse (num el "cx") (num el "cy") (num el "rx") (num el "ry") + "line" -> [MoveTo (Point (num el "x1") (num el "y1")), LineTo (Point (num el "x2") (num el "y2"))] + "polyline" -> poly [] + "polygon" -> poly [ClosePath] + _ -> [] + where + poly close = case parsePoints (value "points" el) of + [] -> [] + p : ps -> MoveTo p : map LineTo ps <> close + +value :: ByteString -> Element -> ByteString +value k = fromMaybe "" . attr k + +len :: Element -> ByteString -> Maybe Float +len el k = attr k el >>= parseLength + +num :: Element -> ByteString -> Float +num el = fromMaybe 0 . len el + +rect :: Float -> Float -> Float -> Float -> Maybe Float -> Maybe Float -> [Segment] +rect x y w h mrx mry + | w <= 0 || h <= 0 = [] + | rx <= 0 || ry <= 0 = [MoveTo (Point x y), LineTo (Point (x + w) y), LineTo (Point (x + w) (y + h)), LineTo (Point x (y + h)), ClosePath] + | otherwise = + [ MoveTo (Point (x + rx) y) + , LineTo (Point (x + w - rx) y) + , corner (Point (x + w) (y + ry)) + , LineTo (Point (x + w) (y + h - ry)) + , corner (Point (x + w - rx) (y + h)) + , LineTo (Point (x + rx) (y + h)) + , corner (Point x (y + h - ry)) + , LineTo (Point x (y + ry)) + , corner (Point (x + rx) y) + , ClosePath + ] + where + -- A missing radius defaults to the other, capped at half the side. + rx = min (w / 2) (abs (fromMaybe 0 (mrx <|> mry))) + ry = min (h / 2) (abs (fromMaybe 0 (mry <|> mrx))) + corner = ArcTo rx ry 0 False True + +ellipse :: Float -> Float -> Float -> Float -> [Segment] +ellipse cx cy rx ry + | rx <= 0 || ry <= 0 = [] + | otherwise = [MoveTo (Point (cx + rx) cy), arc (Point (cx - rx) cy), arc (Point (cx + rx) cy), ClosePath] + where + arc = ArcTo rx ry 0 False True + +-- | Apply one declaration; invalid or unsupported values leave the style as is. +property :: Style -> (ByteString, ByteString) -> Style +property s (k, v) = fromMaybe s case k of + "fill" -> (\p -> s {styleFill = Just p}) <$> parsePaint v + "stroke" -> (\p -> s {styleStroke = Just p}) <$> parsePaint v + "stroke-width" -> (\w -> s {styleStrokeWidth = max 0 w}) <$> parseLength v + "stroke-miterlimit" -> (\l -> s {styleMiterLimit = max 1 l}) <$> parseLength v + "opacity" -> (\o -> s {styleOpacity = o}) <$> parseOpacity v + "fill-opacity" -> (\o -> s {styleFillOpacity = o}) <$> parseOpacity v + "stroke-opacity" -> (\o -> s {styleStrokeOpacity = o}) <$> parseOpacity v + "stroke-linecap" -> (\c -> s {styleCap = c}) <$> lookup kw [("butt", CapButt), ("round", CapRound), ("square", CapSquare)] + "stroke-linejoin" -> (\j -> s {styleJoin = j}) <$> lookup kw [("miter", JoinMiter), ("round", JoinRound), ("bevel", JoinBevel)] + "fill-rule" -> (\r -> s {styleFillRule = r}) <$> lookup kw [("nonzero", NonZero), ("evenodd", EvenOdd)] + _ -> Nothing + where + kw = lower (BC.strip v) + +-- | Split a @style@ attribute into declarations. Not a CSS parser. +declarations :: ByteString -> [(ByteString, ByteString)] +declarations s = + [(lower (BC.strip k), BC.strip (BS.drop 1 v)) | d <- BC.split ';' s, let (k, v) = BC.break (== ':') d, not (BS.null v)] + +lower :: ByteString -> ByteString +lower = BC.map toLower + + +-------------------------------------------------------------------------------- +-- Encoding +-------------------------------------------------------------------------------- + +-- | Write a document as UTF-8 SVG. 'parseSvg' reads the result back to the +-- same view box, size and shapes. +encodeSvg :: Document -> ByteString +encodeSvg = BS.toStrict . B.toLazyByteString . svgBuilder + +-- | 'encodeSvg' as a 'B.Builder': one @path@ per shape, in paint order, with +-- its transform and each property that differs from 'defaultStyle'. +svgBuilder :: Document -> B.Builder +svgBuilder doc = + " attribute "width" (number w) + <> attribute "height" (number h) + <> attribute "viewBox" (spaced (map number [x, y, bw, bh])) + <> ">" + <> foldMap shape (documentShapes doc) + <> "" + where + Box x y bw bh = documentViewBox doc + (w, h) = documentSize doc + +shape :: Shape -> B.Builder +shape (Shape segs m s) = + " attribute "d" (spaced (map segment (toList segs))) + <> (if m == identity then mempty else attribute "transform" (matrix m)) + <> foldMap (attribute "fill" . paint) (styleFill s) + <> foldMap (attribute "fill-opacity" . number) (changed styleFillOpacity) + <> foldMap (attribute "fill-rule" . \case NonZero -> "nonzero"; EvenOdd -> "evenodd") (changed styleFillRule) + <> foldMap (attribute "stroke" . paint) (join (changed styleStroke)) + <> foldMap (attribute "stroke-opacity" . number) (changed styleStrokeOpacity) + <> foldMap (attribute "stroke-width" . number) (changed styleStrokeWidth) + <> foldMap (attribute "stroke-linecap" . \case CapButt -> "butt"; CapRound -> "round"; CapSquare -> "square") (changed styleCap) + <> foldMap (attribute "stroke-linejoin" . \case JoinMiter -> "miter"; JoinRound -> "round"; JoinBevel -> "bevel") (changed styleJoin) + <> foldMap (attribute "stroke-miterlimit" . number) (changed styleMiterLimit) + <> foldMap (attribute "opacity" . number) (changed styleOpacity) + <> "/>" + where + changed :: Eq a => (Style -> a) -> Maybe a + changed field = if field s == field defaultStyle then Nothing else Just (field s) + matrix (Matrix a b c d e f) = "matrix(" <> spaced (map number [a, b, c, d, e, f]) <> ")" + +segment :: Segment -> B.Builder +segment = \case + MoveTo p -> "M" <> point p + LineTo p -> "L" <> point p + CubicTo p q r -> "C" <> spaced [point p, point q, point r] + QuadTo p q -> "Q" <> spaced [point p, point q] + ArcTo rx ry angle large sweep p -> "A" <> spaced [number rx, number ry, number angle, flag large, flag sweep, point p] + ClosePath -> "Z" + where + point (Point px py) = number px <> " " <> number py + flag b = if b then "1" else "0" + +-- | @#rrggbb@, or @#rrggbbaa@ when not opaque. +paint :: Paint -> B.Builder +paint = \case + PaintNone -> "none" + PaintCurrent -> "currentColor" + PaintColor (RGBA c) -> "#" <> foldMap (B.word8HexFixed . channel) (if channel 0 == 255 then [24, 16, 8] else [24, 16, 8, 0]) + where + channel k = fromIntegral (c `shiftR` k) :: Word8 + +-- | The shortest digits that read back as the same 'Float', and an integer +-- without a trailing @.0@. +number :: Float -> B.Builder +number v + | abs v < 1e7, v == fromIntegral i = B.intDec i + | otherwise = B.floatDec v + where + i = truncate v :: Int + +attribute :: B.Builder -> B.Builder -> B.Builder +attribute k v = " " <> k <> "=\"" <> v <> "\"" + +spaced :: [B.Builder] -> B.Builder +spaced = mconcat . intersperse " " + +-------------------------------------------------------------------------------- +-- XML +-------------------------------------------------------------------------------- + +-- | 'geometry' is parsed on first draw and shared by every @use@ of the +-- element. +data Element = Element {tag :: ByteString, attrs :: [(ByteString, ByteString)], geometry :: SmallArray Segment, kids :: [Element]} + +attr :: ByteString -> Element -> Maybe ByteString +attr k = lookup k . attrs + +descendants :: Element -> [Element] +descendants el = go el [] + where + go e rest = e : foldr go rest (kids e) + +-- | Child elements, without the processing instructions hexml reports. +nodes :: X.Node -> [Element] +nodes n = [element c | c <- X.children n, not (BS.isPrefixOf " BS.drop (i + 1) s) (BC.elemIndexEnd ':' s) + +-- | Remove a DOCTYPE, including an internal subset, which hexml rejects. +withoutDoctype :: ByteString -> ByteString +withoutDoctype s = before <> BC.drop 1 (BC.dropWhile (/= '>') decl) + where + (before, doctype) = BS.breakSubstring "') doctype) then BC.dropWhile (/= ']') doctype else doctype + +-- | Decode the predefined entities and character references; leave anything +-- else as written. Linear in the length of the value. +entities :: ByteString -> ByteString +entities v + | BC.notElem '&' v = v + | otherwise = BS.toStrict (B.toLazyByteString (go v)) + where + go s = case BC.break (== '&') s of + (a, b) | BS.null b -> B.byteString a + (a, b) -> B.byteString a <> case BC.break (\c -> c == ';' || c == '&') (BS.drop 1 b) of + -- A reference cannot contain an ampersand, so the scan stops at the + -- next one instead of running on to a distant semicolon. + (ref, rest) | Just rest' <- BC.stripPrefix ";" rest, Just c <- entity ref -> B.charUtf8 c <> go rest' + _ -> B.char7 '&' <> go (BS.drop 1 b) + entity ref = case BC.uncons ref of + Just ('#', n) -> case BC.uncons n of + Just (x, h) | toLower x == 'x' -> scalar F.anyAsciiHexInt h + _ -> scalar F.anyAsciiDecimalInt n + _ -> lookup ref [("amp", '&'), ("lt", '<'), ("gt", '>'), ("quot", '"'), ("apos", '\'')] + -- The digit parsers fail on overflow rather than wrap around. + scalar digits ds = case F.runParser (digits <* F.eof) ds of + F.OK c _ | c > 0, c <= 0x10FFFF, c < 0xD800 || c > 0xDFFF -> Just (chr c) + _ -> Nothing + diff --git a/lib/Graphics/NanoSvg/Attribute.hs b/lib/Graphics/NanoSvg/Attribute.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/NanoSvg/Attribute.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Graphics.NanoSvg.Attribute +-- Copyright : (c) 2026 goolord +-- License : MIT +-- +-- Parsers for individual SVG attribute values. Each accepts surrounding +-- whitespace, and returns 'Nothing' (or an empty or identity result) for +-- values it cannot read. +module Graphics.NanoSvg.Attribute + ( parseNumber + , parseNumberList + , parsePoints + , parseLength + , parseOpacity + , parsePath + , parseTransform + , parsePaint + , parseColor + ) +where + +import Control.Applicative (empty, many, optional, (<|>)) +import Control.Monad (guard) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BC +import Data.Char (digitToInt, isAsciiLower, isAsciiUpper, isDigit, isHexDigit, isSpace, toLower) +import Data.Fixed (mod') +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import FlatParse.Basic qualified as F +import GHC.Float (double2Float) +import Graphics.NanoSvg.Types + +type P = F.Parser () + +-- | Run a parser over a whole value with optional surrounding whitespace. +whole :: P a -> ByteString -> Maybe a +whole p s = case F.runParser (wsp *> p <* wsp <* F.eof) s of + F.OK a _ -> Just a + _ -> Nothing + +-- | Run a parser over a prefix of a value, ignoring the rest. +prefix :: a -> P a -> ByteString -> a +prefix def p s = case F.runParser p s of + F.OK a _ -> a + _ -> def + +wsp, sep :: P () +wsp = F.skipMany (F.skipSatisfyAscii isSpace) +sep = F.skipMany (F.skipSatisfyAscii (\c -> isSpace c || c == ',')) + +sym :: Char -> P () +sym c = F.skipSatisfyAscii (== c) + +letter :: Char -> Bool +letter c = isAsciiLower c || isAsciiUpper c + +letters :: P ByteString +letters = F.byteStringOf (F.skipSome (F.skipSatisfyAscii letter)) + +word :: P ByteString +word = lower <$> letters + +lower :: ByteString -> ByteString +lower = BC.map toLower + +-- | A finite number, as in @1@, @-.5@, @1.@ or @1.5e+2@. +parseNumber :: ByteString -> Maybe Float +parseNumber = whole number + +number :: P Float +number = do + neg <- minus + int <- digits + frac <- (sym '.' *> digits) <|> pure BS.empty + guard (not (BS.null int && BS.null frac)) + -- An @e@ without digits after it belongs to a unit, as in @1em@. + e <- (F.skipSatisfyAscii (`elem` ['e', 'E']) *> power) <|> pure 0 + -- Past 18 significant digits a Float cannot tell the difference, so the + -- rest only shift the exponent, and the mantissa fits a Double exactly. + let ds = BS.dropWhile (== 48) (int <> frac) + sig = BS.take 18 ds + k = e - BS.length frac + BS.length ds - BS.length sig + m = BS.foldl' step 0 sig + x + | m == 0 || k < -80 = 0 + | k > 40 = 1 / 0 + | k < 0 = double2Float (m / 10 ^ negate k) + | otherwise = double2Float (m * 10 ^ k) + guard (not (isInfinite x)) + pure (if neg then negate x else x) + where + minus = (True <$ sym '-') <|> (False <$ sym '+') <|> pure False + digits = F.byteStringOf (F.skipMany (F.skipSatisfyAscii isDigit)) + step acc d = acc * 10 + fromIntegral (d - 48) :: Double + power = do + neg <- minus + k <- BS.foldl' (\acc d -> min 9999 (acc * 10 + fromIntegral d - 48)) 0 <$> F.byteStringOf (F.skipSome (F.skipSatisfyAscii isDigit)) + pure (if neg then negate k else k :: Int) + +-- | Numbers separated by whitespace or commas, up to the first non-number. +parseNumberList :: ByteString -> [Float] +parseNumberList = prefix [] numbers + +-- | Coordinate pairs, as in @points@, up to the first incomplete pair. +parsePoints :: ByteString -> [Point] +parsePoints = prefix [] (sep *> many (Point <$> arg <*> arg)) + +-- | An opacity or percentage, clamped to [0, 1]. +parseOpacity :: ByteString -> Maybe Float +parseOpacity v = max 0 . min 1 <$> (whole ((/ 100) <$> number <* sym '%') v <|> parseLength v) + +numbers :: P [Float] +numbers = sep *> many arg + +arg :: P Float +arg = number <* sep + +-- | A length in user units at 96 per inch. Relative units (@%@, @em@, @ex@) +-- give 'Nothing'. +parseLength :: ByteString -> Maybe Float +parseLength v = do + (x, u) <- whole ((,) <$> number <*> (word <|> pure BS.empty)) v + ($ x) <$> lookup u [("", id), ("px", id), ("pt", (/ 72) . (* 96)), ("pc", (* 16)), ("in", (* 96)), ("cm", (/ 2.54) . (* 96)), ("mm", (/ 25.4) . (* 96))] + +-- | The @d@ attribute as absolute segments, keeping those before any error. +parsePath :: ByteString -> [Segment] +parsePath = prefix [] (path 'M' (Point 0 0) (MoveTo (Point 0 0)) []) + +-- | The rest of a path, given the command to repeat, the subpath start, the +-- previous segment and the segments so far in reverse. +path :: Char -> Point -> Segment -> [Segment] -> P [Segment] +path cmd !start !prev acc = do + c <- sep *> ((F.satisfyAscii letter <* sep) <|> pure cmd) + let rel = isAsciiLower c + -- Arguments after a moveto are linetos, and a closepath returns to the start. + next seg = case seg of + MoveTo p -> path (if rel then 'l' else 'L') p seg (seg : acc) + ClosePath -> path (if rel then 'm' else 'M') start seg (seg : acc) + _ -> path c start seg (seg : acc) + F.withOption (segment c start prev) next (pure (reverse acc)) + +-- | One command's segment, given the subpath start and the previous segment. +segment :: Char -> Point -> Segment -> P Segment +segment c start prev = case toLower c of + 'm' -> MoveTo <$> pt + 'z' -> pure ClosePath + 'l' -> LineTo <$> pt + 'h' -> LineTo . (\x -> Point (if rel then cx + x else x) cy) <$> arg + 'v' -> LineTo . (\y -> Point cx (if rel then cy + y else y)) <$> arg + 'c' -> CubicTo <$> pt <*> pt <*> pt + 's' -> CubicTo (case prev of CubicTo _ q _ -> reflect q; _ -> cur) <$> pt <*> pt + 'q' -> QuadTo <$> pt <*> pt + 't' -> QuadTo (case prev of QuadTo q _ -> reflect q; _ -> cur) <$> pt + 'a' -> ArcTo <$> (abs <$> arg) <*> (abs <$> arg) <*> arg <*> flag <*> flag <*> pt + _ -> empty + where + cur@(Point cx cy) = case prev of + MoveTo p -> p + LineTo p -> p + CubicTo _ _ p -> p + QuadTo _ p -> p + ArcTo _ _ _ _ _ p -> p + ClosePath -> start + reflect (Point x y) = Point (2 * cx - x) (2 * cy - y) + rel = isAsciiLower c + pt = (\x y -> if rel then Point (cx + x) (cy + y) else Point x y) <$> arg <*> arg + -- Flags need no separator, as in @a1 1 0 00.5.5@. + flag = (== '1') <$> F.satisfyAscii (`elem` ['0', '1']) <* sep + +-- | A @transform@ list, the rightmost acting first. Unknown functions are the +-- identity, and malformed syntax ends the list. +parseTransform :: ByteString -> Matrix +parseTransform = prefix identity (foldl' multiply identity <$> (sep *> many item)) + where + item = do + name <- letters <* wsp <* sym '(' + args <- numbers <* wsp <* sym ')' <* sep + pure case (name, args) of + ("matrix", [a, b, c, d, e, f]) -> Matrix a b c d e f + ("translate", [x]) -> translate x 0 + ("translate", [x, y]) -> translate x y + ("scale", [k]) -> Matrix k 0 0 k 0 0 + ("scale", [x, y]) -> Matrix x 0 0 y 0 0 + ("rotate", [a]) -> rotate a + ("rotate", [a, x, y]) -> translate x y `multiply` rotate a `multiply` translate (-x) (-y) + ("skewX", [a]) -> Matrix 1 0 (tan (radians a)) 1 0 0 + ("skewY", [a]) -> Matrix 1 (tan (radians a)) 0 1 0 0 + _ -> identity + radians a = a * pi / 180 + rotate a = let r = radians a in Matrix (cos r) (sin r) (-sin r) (cos r) 0 0 + +-- | A @fill@ or @stroke@ value. @url()@ and @inherit@ give 'Nothing'. +parsePaint :: ByteString -> Maybe Paint +parsePaint v = case lower (BC.strip v) of + "none" -> Just PaintNone + "transparent" -> Just PaintNone + "currentcolor" -> Just PaintCurrent + _ -> PaintColor <$> parseColor v + +-- | A @#rgb@, @#rgba@, @#rrggbb@ or @#rrggbbaa@ color; @rgb()@, @rgba()@, +-- @hsl()@ or @hsla()@ with comma or space separators; or a named color. +parseColor :: ByteString -> Maybe RGBA +parseColor = whole color + +color :: P RGBA +color = (sym '#' *> hex) <|> do + name <- word + (sym '(' *> wsp *> function name <* wsp <* sym ')') <|> maybe empty pure (Map.lookup name namedColors) + +hex :: P RGBA +hex = do + ds <- map (fromIntegral . digitToInt) . BC.unpack <$> F.byteStringOf (F.skipMany (F.skipSatisfyAscii isHexDigit)) + let pairs = \case + a : b : r -> a * 16 + b : pairs r + _ -> [] + case if length ds `elem` [3, 4] then map (* 17) ds else if even (length ds) then pairs ds else [] of + [r, g, b] -> pure (rgba r g b 255) + [r, g, b, a] -> pure (rgba r g b a) + _ -> empty + +function :: ByteString -> P RGBA +function name + | name `elem` ["rgb", "rgba"] = rgba <$> channel <*> (comma *> channel) <*> (comma *> channel) <*> alpha + | name `elem` ["hsl", "hsla"] = do + h <- number <* optional (F.byteString "deg") + s <- comma *> percent + l <- comma *> percent + let a = s * min l (1 - l) + f n = let k = mod' (n + h / 30) 12 in byte (255 * (l - a * max (-1) (min 1 (min (k - 3) (9 - k))))) + rgba (f 0) (f 8) (f 4) <$> alpha + | otherwise = empty + where + comma = wsp *> optional (F.skipSatisfyAscii (`elem` [',', '/'])) *> wsp + scaled full = number >>= \x -> (x * full / 100 <$ sym '%') <|> pure x + channel = byte <$> scaled 255 + percent = max 0 . min 1 . (/ 100) <$> number <* optional (sym '%') + alpha = (comma *> (byte . (255 *) . max 0 . min 1 <$> scaled 1)) <|> pure 255 + byte x = fromIntegral (max 0 (min 255 (round x :: Int))) + +-- | The CSS named colors, excluding the paint keywords. +namedColors :: Map ByteString RGBA +namedColors = Map.fromList (pairs (BC.words table)) + where + pairs (n : c : r) = (n, prefix black hex c) : pairs r + pairs _ = [] + table = + "aliceblue f0f8ff antiquewhite faebd7 aqua 00ffff aquamarine 7fffd4 azure f0ffff \ + \beige f5f5dc bisque ffe4c4 black 000000 blanchedalmond ffebcd blue 0000ff \ + \blueviolet 8a2be2 brown a52a2a burlywood deb887 cadetblue 5f9ea0 chartreuse 7fff00 \ + \chocolate d2691e coral ff7f50 cornflowerblue 6495ed cornsilk fff8dc crimson dc143c \ + \cyan 00ffff darkblue 00008b darkcyan 008b8b darkgoldenrod b8860b darkgray a9a9a9 \ + \darkgreen 006400 darkgrey a9a9a9 darkkhaki bdb76b darkmagenta 8b008b darkolivegreen \ + \556b2f darkorange ff8c00 darkorchid 9932cc darkred 8b0000 darksalmon e9967a \ + \darkseagreen 8fbc8f darkslateblue 483d8b darkslategray 2f4f4f darkslategrey 2f4f4f \ + \darkturquoise 00ced1 darkviolet 9400d3 deeppink ff1493 deepskyblue 00bfff dimgray \ + \696969 dimgrey 696969 dodgerblue 1e90ff firebrick b22222 floralwhite fffaf0 \ + \forestgreen 228b22 fuchsia ff00ff gainsboro dcdcdc ghostwhite f8f8ff gold ffd700 \ + \goldenrod daa520 gray 808080 green 008000 greenyellow adff2f grey 808080 honeydew \ + \f0fff0 hotpink ff69b4 indianred cd5c5c indigo 4b0082 ivory fffff0 khaki f0e68c \ + \lavender e6e6fa lavenderblush fff0f5 lawngreen 7cfc00 lemonchiffon fffacd lightblue \ + \add8e6 lightcoral f08080 lightcyan e0ffff lightgoldenrodyellow fafad2 lightgray \ + \d3d3d3 lightgreen 90ee90 lightgrey d3d3d3 lightpink ffb6c1 lightsalmon ffa07a \ + \lightseagreen 20b2aa lightskyblue 87cefa lightslategray 778899 lightslategrey \ + \778899 lightsteelblue b0c4de lightyellow ffffe0 lime 00ff00 limegreen 32cd32 linen \ + \faf0e6 magenta ff00ff maroon 800000 mediumaquamarine 66cdaa mediumblue 0000cd \ + \mediumorchid ba55d3 mediumpurple 9370db mediumseagreen 3cb371 mediumslateblue \ + \7b68ee mediumspringgreen 00fa9a mediumturquoise 48d1cc mediumvioletred c71585 \ + \midnightblue 191970 mintcream f5fffa mistyrose ffe4e1 moccasin ffe4b5 navajowhite \ + \ffdead navy 000080 oldlace fdf5e6 olive 808000 olivedrab 6b8e23 orange ffa500 \ + \orangered ff4500 orchid da70d6 palegoldenrod eee8aa palegreen 98fb98 paleturquoise \ + \afeeee palevioletred db7093 papayawhip ffefd5 peachpuff ffdab9 peru cd853f pink \ + \ffc0cb plum dda0dd powderblue b0e0e6 purple 800080 rebeccapurple 663399 red ff0000 \ + \rosybrown bc8f8f royalblue 4169e1 saddlebrown 8b4513 salmon fa8072 sandybrown \ + \f4a460 seagreen 2e8b57 seashell fff5ee sienna a0522d silver c0c0c0 skyblue 87ceeb \ + \slateblue 6a5acd slategray 708090 slategrey 708090 snow fffafa springgreen 00ff7f \ + \steelblue 4682b4 tan d2b48c teal 008080 thistle d8bfd8 tomato ff6347 turquoise \ + \40e0d0 violet ee82ee wheat f5deb3 white ffffff whitesmoke f5f5f5 yellow ffff00 \ + \yellowgreen 9acd32" diff --git a/lib/Graphics/NanoSvg/Color.hs b/lib/Graphics/NanoSvg/Color.hs deleted file mode 100644 --- a/lib/Graphics/NanoSvg/Color.hs +++ /dev/null @@ -1,371 +0,0 @@ --- | --- Module : Graphics.NanoSvg.Color --- Copyright : (c) 2026 goolord --- License : MIT --- --- Colors and paints. --- --- Supports @none@, @transparent@ and @currentColor@; the --- hexadecimal forms @#rgb@, @#rgba@, @#rrggbb@ and @#rrggbbaa@; the --- functions @rgb()@, @rgba()@, @hsl()@ and @hsla()@, with their arguments --- separated by commas or by spaces and an alpha after a slash as CSS Color --- 4 writes them; and all 148 named CSS colors. Names are case-insensitive. --- Hue accepts degrees only, with an optional @deg@ suffix. --- --- Paint servers (@url()@), @inherit@ and system colors are unsupported. --- 'parsePaint' and 'parseColor' return 'Nothing' for invalid or unsupported --- values and require the whole input, apart from surrounding whitespace. -module Graphics.NanoSvg.Color - ( -- * Paints - paint - , parsePaint - - -- * Colors - , color - , parseColor - - -- * Named colors - , namedColor - , namedColors - ) -where - -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Word (Word8) -import FlatParse.Basic qualified as F -import Graphics.NanoSvg.Internal.Parser -import Graphics.NanoSvg.Number (number) -import Graphics.NanoSvg.Types (Paint (..), RGBA, rgba) - --------------------------------------------------------------------------------- --- Paints --------------------------------------------------------------------------------- - --- | Parse a paint with optional surrounding whitespace. Both @none@ and --- @transparent@ become 'PaintNone'; @currentColor@ becomes 'PaintCurrent'. -paint :: P Paint -paint = skipWsp *> value <* skipWsp - where - value = - F.withOption - (skipSatisfyByte (== 0x23)) - (const (PaintColor <$> hexColor)) - (named keyword (fmap PaintColor . functional) (fmap PaintColor . namedColor)) - keyword = \case - "none" -> Just PaintNone - "transparent" -> Just PaintNone - "currentcolor" -> Just PaintCurrent - _ -> Nothing - --- | Parse a complete @fill@ or @stroke@ value. 'Nothing' lets the caller --- ignore the declaration and retain the previous paint. -parsePaint :: ByteString -> Maybe Paint -parsePaint src = evaluate src paint - --------------------------------------------------------------------------------- --- Colors --------------------------------------------------------------------------------- - --- | Parse a hex, RGB, HSL or named color without surrounding whitespace. --- Paint-only keywords (@none@, @transparent@, @currentColor@) are rejected. -color :: P RGBA -color = - F.withOption - (skipSatisfyByte (== 0x23)) - (const hexColor) - (named (const Nothing) functional namedColor) - --- | Read and lowercase a name, then dispatch to a keyword, function or table. -named :: (ByteString -> Maybe a) -> (ByteString -> P a) -> (ByteString -> Maybe a) -> P a -named keyword call table = do - name <- lowercase <$> takeWhileByte isAsciiAlpha - if BS.null name - then F.failed - else case keyword name of - Just a -> a <$ F.fails (skipSatisfyByte (== 0x28)) - -- An opening parenthesis distinguishes functions from named colors. - Nothing -> - F.withOption - (skipSatisfyByte (== 0x28)) - (const (call name)) - (maybe F.failed pure (table name)) - --- | Parse a complete color with optional surrounding whitespace. --- Accepts the forms supported by 'color', not paint-only keywords. -parseColor :: ByteString -> Maybe RGBA -parseColor src = evaluate src (skipWsp *> color <* skipWsp) - --- | The digits after a @#@: three, four, six or eight of them, the short --- forms doubling each digit so that @#f90@ is @#ff9900@. -hexColor :: P RGBA -hexColor = do - ds <- takeWhileByte isHexDigit - let at i = hexValue (BS.index ds i) - wide i = at (2 * i) * 16 + at (2 * i + 1) - short i = let v = at i in v * 16 + v - case BS.length ds of - 3 -> pure (rgba (short 0) (short 1) (short 2) 0xFF) - 4 -> pure (rgba (short 0) (short 1) (short 2) (short 3)) - 6 -> pure (rgba (wide 0) (wide 1) (wide 2) 0xFF) - 8 -> pure (rgba (wide 0) (wide 1) (wide 2) (wide 3)) - _ -> F.failed - --- | Parse a color function after its name and opening parenthesis. -functional :: ByteString -> P RGBA -functional name = do - c <- case name of - "rgb" -> rgbBody - "rgba" -> rgbBody - "hsl" -> hslBody - "hsla" -> hslBody - _ -> F.failed - skipWsp - skipSatisfyByte (== 0x29) - pure c - -rgbBody :: P RGBA -rgbBody = do - skipWsp - r <- channel - argSep - g <- channel - argSep - b <- channel - a <- opacity - pure (rgba r g b a) - -hslBody :: P RGBA -hslBody = do - skipWsp - h <- hue - argSep - s <- percentage - argSep - l <- percentage - a <- opacity - let (r, g, b) = hslToRgb h s l - pure (rgba r g b a) - --- | A number, scaled if a @%@ follows it: @full@ is what @100%@ stands for. -scaled :: Float -> P Float -scaled full = do - x <- number - F.withOption (skipSatisfyByte (== 0x25)) (const (pure (x * full / 100))) (pure x) - --- | One of @r@, @g@ or @b@: a number out of 255, or a percentage. -channel :: P Word8 -channel = round8 <$> scaled 255 - --- | Hue in degrees, optionally followed by @deg@. -hue :: P Float -hue = number <* F.optional_ (F.byteString "deg") - --- | Percentage converted to [0, 1]. Also accepts a bare number as a percentage. -percentage :: P Float -percentage = do - x <- number - F.optional_ (skipSatisfyByte (== 0x25)) - pure (clamp01 (x / 100)) - --- | The alpha argument, if there is one. It may be introduced by a comma, --- as @rgba()@ writes it, or by a slash, as CSS Color 4 does. -opacity :: P Word8 -opacity = (argSep *> alpha) F.<|> pure 0xFF - where - alpha = round8 . (255 *) . clamp01 <$> scaled 1 - --- | Whitespace, at most one comma or slash, whitespace. -argSep :: P () -argSep = do - skipWsp - F.optional_ (skipSatisfyByte (\w -> w == 0x2C || w == 0x2F)) - skipWsp - --------------------------------------------------------------------------------- --- Named colors --------------------------------------------------------------------------------- - --- | Look up one of the CSS color keywords. The name must already be --- lowercase. -namedColor :: ByteString -> Maybe RGBA -namedColor name = Map.lookup name namedColorMap - -namedColorMap :: Map ByteString RGBA -namedColorMap = Map.fromList namedColors -{-# NOINLINE namedColorMap #-} - --------------------------------------------------------------------------------- --- Conversions --------------------------------------------------------------------------------- - --- | CSS Color 3's conversion, with hue wrapped into a turn and saturation --- and lightness already clamped. -hslToRgb :: Float -> Float -> Float -> (Word8, Word8, Word8) -hslToRgb h s l = (round8 (255 * f 0), round8 (255 * f 8), round8 (255 * f 4)) - where - h' = h / 30 - a = s * min l (1 - l) - f n = - let k = wrap12 (n + h') - in l - a * max (-1) (min 1 (min (k - 3) (9 - k))) - wrap12 x = x - 12 * fromIntegral (floor (x / 12) :: Int) - -{-# INLINE round8 #-} -round8 :: Float -> Word8 -round8 x = fromIntegral (max 0 (min 255 (round x :: Int))) - --- | The 148 named CSS colors, sorted by lowercase name. Excludes paint keywords. -namedColors :: [(ByteString, RGBA)] -namedColors = - [ ("aliceblue", rgba 0xf0 0xf8 0xff 0xFF) - , ("antiquewhite", rgba 0xfa 0xeb 0xd7 0xFF) - , ("aqua", rgba 0x00 0xff 0xff 0xFF) - , ("aquamarine", rgba 0x7f 0xff 0xd4 0xFF) - , ("azure", rgba 0xf0 0xff 0xff 0xFF) - , ("beige", rgba 0xf5 0xf5 0xdc 0xFF) - , ("bisque", rgba 0xff 0xe4 0xc4 0xFF) - , ("black", rgba 0x00 0x00 0x00 0xFF) - , ("blanchedalmond", rgba 0xff 0xeb 0xcd 0xFF) - , ("blue", rgba 0x00 0x00 0xff 0xFF) - , ("blueviolet", rgba 0x8a 0x2b 0xe2 0xFF) - , ("brown", rgba 0xa5 0x2a 0x2a 0xFF) - , ("burlywood", rgba 0xde 0xb8 0x87 0xFF) - , ("cadetblue", rgba 0x5f 0x9e 0xa0 0xFF) - , ("chartreuse", rgba 0x7f 0xff 0x00 0xFF) - , ("chocolate", rgba 0xd2 0x69 0x1e 0xFF) - , ("coral", rgba 0xff 0x7f 0x50 0xFF) - , ("cornflowerblue", rgba 0x64 0x95 0xed 0xFF) - , ("cornsilk", rgba 0xff 0xf8 0xdc 0xFF) - , ("crimson", rgba 0xdc 0x14 0x3c 0xFF) - , ("cyan", rgba 0x00 0xff 0xff 0xFF) - , ("darkblue", rgba 0x00 0x00 0x8b 0xFF) - , ("darkcyan", rgba 0x00 0x8b 0x8b 0xFF) - , ("darkgoldenrod", rgba 0xb8 0x86 0x0b 0xFF) - , ("darkgray", rgba 0xa9 0xa9 0xa9 0xFF) - , ("darkgreen", rgba 0x00 0x64 0x00 0xFF) - , ("darkgrey", rgba 0xa9 0xa9 0xa9 0xFF) - , ("darkkhaki", rgba 0xbd 0xb7 0x6b 0xFF) - , ("darkmagenta", rgba 0x8b 0x00 0x8b 0xFF) - , ("darkolivegreen", rgba 0x55 0x6b 0x2f 0xFF) - , ("darkorange", rgba 0xff 0x8c 0x00 0xFF) - , ("darkorchid", rgba 0x99 0x32 0xcc 0xFF) - , ("darkred", rgba 0x8b 0x00 0x00 0xFF) - , ("darksalmon", rgba 0xe9 0x96 0x7a 0xFF) - , ("darkseagreen", rgba 0x8f 0xbc 0x8f 0xFF) - , ("darkslateblue", rgba 0x48 0x3d 0x8b 0xFF) - , ("darkslategray", rgba 0x2f 0x4f 0x4f 0xFF) - , ("darkslategrey", rgba 0x2f 0x4f 0x4f 0xFF) - , ("darkturquoise", rgba 0x00 0xce 0xd1 0xFF) - , ("darkviolet", rgba 0x94 0x00 0xd3 0xFF) - , ("deeppink", rgba 0xff 0x14 0x93 0xFF) - , ("deepskyblue", rgba 0x00 0xbf 0xff 0xFF) - , ("dimgray", rgba 0x69 0x69 0x69 0xFF) - , ("dimgrey", rgba 0x69 0x69 0x69 0xFF) - , ("dodgerblue", rgba 0x1e 0x90 0xff 0xFF) - , ("firebrick", rgba 0xb2 0x22 0x22 0xFF) - , ("floralwhite", rgba 0xff 0xfa 0xf0 0xFF) - , ("forestgreen", rgba 0x22 0x8b 0x22 0xFF) - , ("fuchsia", rgba 0xff 0x00 0xff 0xFF) - , ("gainsboro", rgba 0xdc 0xdc 0xdc 0xFF) - , ("ghostwhite", rgba 0xf8 0xf8 0xff 0xFF) - , ("gold", rgba 0xff 0xd7 0x00 0xFF) - , ("goldenrod", rgba 0xda 0xa5 0x20 0xFF) - , ("gray", rgba 0x80 0x80 0x80 0xFF) - , ("green", rgba 0x00 0x80 0x00 0xFF) - , ("greenyellow", rgba 0xad 0xff 0x2f 0xFF) - , ("grey", rgba 0x80 0x80 0x80 0xFF) - , ("honeydew", rgba 0xf0 0xff 0xf0 0xFF) - , ("hotpink", rgba 0xff 0x69 0xb4 0xFF) - , ("indianred", rgba 0xcd 0x5c 0x5c 0xFF) - , ("indigo", rgba 0x4b 0x00 0x82 0xFF) - , ("ivory", rgba 0xff 0xff 0xf0 0xFF) - , ("khaki", rgba 0xf0 0xe6 0x8c 0xFF) - , ("lavender", rgba 0xe6 0xe6 0xfa 0xFF) - , ("lavenderblush", rgba 0xff 0xf0 0xf5 0xFF) - , ("lawngreen", rgba 0x7c 0xfc 0x00 0xFF) - , ("lemonchiffon", rgba 0xff 0xfa 0xcd 0xFF) - , ("lightblue", rgba 0xad 0xd8 0xe6 0xFF) - , ("lightcoral", rgba 0xf0 0x80 0x80 0xFF) - , ("lightcyan", rgba 0xe0 0xff 0xff 0xFF) - , ("lightgoldenrodyellow", rgba 0xfa 0xfa 0xd2 0xFF) - , ("lightgray", rgba 0xd3 0xd3 0xd3 0xFF) - , ("lightgreen", rgba 0x90 0xee 0x90 0xFF) - , ("lightgrey", rgba 0xd3 0xd3 0xd3 0xFF) - , ("lightpink", rgba 0xff 0xb6 0xc1 0xFF) - , ("lightsalmon", rgba 0xff 0xa0 0x7a 0xFF) - , ("lightseagreen", rgba 0x20 0xb2 0xaa 0xFF) - , ("lightskyblue", rgba 0x87 0xce 0xfa 0xFF) - , ("lightslategray", rgba 0x77 0x88 0x99 0xFF) - , ("lightslategrey", rgba 0x77 0x88 0x99 0xFF) - , ("lightsteelblue", rgba 0xb0 0xc4 0xde 0xFF) - , ("lightyellow", rgba 0xff 0xff 0xe0 0xFF) - , ("lime", rgba 0x00 0xff 0x00 0xFF) - , ("limegreen", rgba 0x32 0xcd 0x32 0xFF) - , ("linen", rgba 0xfa 0xf0 0xe6 0xFF) - , ("magenta", rgba 0xff 0x00 0xff 0xFF) - , ("maroon", rgba 0x80 0x00 0x00 0xFF) - , ("mediumaquamarine", rgba 0x66 0xcd 0xaa 0xFF) - , ("mediumblue", rgba 0x00 0x00 0xcd 0xFF) - , ("mediumorchid", rgba 0xba 0x55 0xd3 0xFF) - , ("mediumpurple", rgba 0x93 0x70 0xdb 0xFF) - , ("mediumseagreen", rgba 0x3c 0xb3 0x71 0xFF) - , ("mediumslateblue", rgba 0x7b 0x68 0xee 0xFF) - , ("mediumspringgreen", rgba 0x00 0xfa 0x9a 0xFF) - , ("mediumturquoise", rgba 0x48 0xd1 0xcc 0xFF) - , ("mediumvioletred", rgba 0xc7 0x15 0x85 0xFF) - , ("midnightblue", rgba 0x19 0x19 0x70 0xFF) - , ("mintcream", rgba 0xf5 0xff 0xfa 0xFF) - , ("mistyrose", rgba 0xff 0xe4 0xe1 0xFF) - , ("moccasin", rgba 0xff 0xe4 0xb5 0xFF) - , ("navajowhite", rgba 0xff 0xde 0xad 0xFF) - , ("navy", rgba 0x00 0x00 0x80 0xFF) - , ("oldlace", rgba 0xfd 0xf5 0xe6 0xFF) - , ("olive", rgba 0x80 0x80 0x00 0xFF) - , ("olivedrab", rgba 0x6b 0x8e 0x23 0xFF) - , ("orange", rgba 0xff 0xa5 0x00 0xFF) - , ("orangered", rgba 0xff 0x45 0x00 0xFF) - , ("orchid", rgba 0xda 0x70 0xd6 0xFF) - , ("palegoldenrod", rgba 0xee 0xe8 0xaa 0xFF) - , ("palegreen", rgba 0x98 0xfb 0x98 0xFF) - , ("paleturquoise", rgba 0xaf 0xee 0xee 0xFF) - , ("palevioletred", rgba 0xdb 0x70 0x93 0xFF) - , ("papayawhip", rgba 0xff 0xef 0xd5 0xFF) - , ("peachpuff", rgba 0xff 0xda 0xb9 0xFF) - , ("peru", rgba 0xcd 0x85 0x3f 0xFF) - , ("pink", rgba 0xff 0xc0 0xcb 0xFF) - , ("plum", rgba 0xdd 0xa0 0xdd 0xFF) - , ("powderblue", rgba 0xb0 0xe0 0xe6 0xFF) - , ("purple", rgba 0x80 0x00 0x80 0xFF) - , ("rebeccapurple", rgba 0x66 0x33 0x99 0xFF) - , ("red", rgba 0xff 0x00 0x00 0xFF) - , ("rosybrown", rgba 0xbc 0x8f 0x8f 0xFF) - , ("royalblue", rgba 0x41 0x69 0xe1 0xFF) - , ("saddlebrown", rgba 0x8b 0x45 0x13 0xFF) - , ("salmon", rgba 0xfa 0x80 0x72 0xFF) - , ("sandybrown", rgba 0xf4 0xa4 0x60 0xFF) - , ("seagreen", rgba 0x2e 0x8b 0x57 0xFF) - , ("seashell", rgba 0xff 0xf5 0xee 0xFF) - , ("sienna", rgba 0xa0 0x52 0x2d 0xFF) - , ("silver", rgba 0xc0 0xc0 0xc0 0xFF) - , ("skyblue", rgba 0x87 0xce 0xeb 0xFF) - , ("slateblue", rgba 0x6a 0x5a 0xcd 0xFF) - , ("slategray", rgba 0x70 0x80 0x90 0xFF) - , ("slategrey", rgba 0x70 0x80 0x90 0xFF) - , ("snow", rgba 0xff 0xfa 0xfa 0xFF) - , ("springgreen", rgba 0x00 0xff 0x7f 0xFF) - , ("steelblue", rgba 0x46 0x82 0xb4 0xFF) - , ("tan", rgba 0xd2 0xb4 0x8c 0xFF) - , ("teal", rgba 0x00 0x80 0x80 0xFF) - , ("thistle", rgba 0xd8 0xbf 0xd8 0xFF) - , ("tomato", rgba 0xff 0x63 0x47 0xFF) - , ("turquoise", rgba 0x40 0xe0 0xd0 0xFF) - , ("violet", rgba 0xee 0x82 0xee 0xFF) - , ("wheat", rgba 0xf5 0xde 0xb3 0xFF) - , ("white", rgba 0xff 0xff 0xff 0xFF) - , ("whitesmoke", rgba 0xf5 0xf5 0xf5 0xFF) - , ("yellow", rgba 0xff 0xff 0x00 0xFF) - , ("yellowgreen", rgba 0x9a 0xcd 0x32 0xFF) - ] diff --git a/lib/Graphics/NanoSvg/Internal/Parser.hs b/lib/Graphics/NanoSvg/Internal/Parser.hs deleted file mode 100644 --- a/lib/Graphics/NanoSvg/Internal/Parser.hs +++ /dev/null @@ -1,179 +0,0 @@ --- | --- Module : Graphics.NanoSvg.Internal.Parser --- Copyright : (c) 2026 goolord --- License : MIT --- --- Shared @flatparse@ type, byte combinators and attribute parser runners. --- --- Parsers carry no error messages. Callers choose whole-input validation --- with 'evaluate' or prefix parsing with 'runPartial'. --- --- Exposed because public parser signatures use 'P'; this module's API is --- not stable. -module Graphics.NanoSvg.Internal.Parser - ( -- * Parsers - P - - -- * Running - , evaluate - , runPartial - - -- * Bytes - , satisfyByte - , skipSatisfyByte - , skipWhileByte - , takeWhileByte - , peekByte - - -- * Character classes - , isWsp - , isDigitByte - , isHexDigit - , isAsciiAlpha - , hexValue - , lower - , lowercase - - -- * Whitespace - , skipWsp - , skipWspComma - , strip - - -- * Numbers - , clamp01 - ) -where - -import Data.Bits ((.|.)) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.Word (Word8) -import FlatParse.Basic qualified as F - --------------------------------------------------------------------------------- --- Types --------------------------------------------------------------------------------- - --- | Pure byte parser without diagnostic errors. -type P = F.Parser () - --------------------------------------------------------------------------------- --- Running --------------------------------------------------------------------------------- - --- | Run a parser, requiring complete input consumption. Returns 'Nothing' --- on failure or leftover input. Does not skip whitespace automatically. -evaluate :: ByteString -> P a -> Maybe a -evaluate src p = case F.runParser (p <* F.eof) src of - F.OK a _ -> Just a - _ -> Nothing -{-# INLINE evaluate #-} - --- | Run a parser and return its value and unconsumed input. --- Returns 'Nothing' on failure. -runPartial :: ByteString -> P a -> Maybe (a, ByteString) -runPartial src p = case F.runParser p src of - F.OK a rest -> Just (a, rest) - _ -> Nothing -{-# INLINE runPartial #-} - --------------------------------------------------------------------------------- --- Bytes --------------------------------------------------------------------------------- - --- | One byte matching a predicate. -satisfyByte :: (Word8 -> Bool) -> P Word8 -satisfyByte f = F.withAnyWord8 \w -> if f w then pure w else F.failed -{-# INLINE satisfyByte #-} - --- | One byte matching a predicate, discarded. -skipSatisfyByte :: (Word8 -> Bool) -> P () -skipSatisfyByte f = F.withAnyWord8 \w -> if f w then pure () else F.failed -{-# INLINE skipSatisfyByte #-} - --- | Skip zero or more consecutive bytes matching a predicate. -skipWhileByte :: (Word8 -> Bool) -> P () -skipWhileByte f = F.skipMany (skipSatisfyByte f) -{-# INLINE skipWhileByte #-} - --- | Read zero or more matching bytes as a slice sharing the input buffer. -takeWhileByte :: (Word8 -> Bool) -> P ByteString -takeWhileByte f = F.byteStringOf (skipWhileByte f) -{-# INLINE takeWhileByte #-} - --- | The next byte without consuming it, or 'Nothing' at the end of input. -peekByte :: P (Maybe Word8) -peekByte = F.lookahead (F.optional F.anyWord8) -{-# INLINE peekByte #-} - --------------------------------------------------------------------------------- --- Character classes --------------------------------------------------------------------------------- - --- | Accepted whitespace: space, tab, line feed, carriage return or form feed. -{-# INLINE isWsp #-} -isWsp :: Word8 -> Bool -isWsp w = w == 0x20 || w == 0x09 || w == 0x0A || w == 0x0D || w == 0x0C - --- | An ASCII digit. -{-# INLINE isDigitByte #-} -isDigitByte :: Word8 -> Bool -isDigitByte w = w >= 0x30 && w <= 0x39 - --- | A hexadecimal digit, in either case. -{-# INLINE isHexDigit #-} -isHexDigit :: Word8 -> Bool -isHexDigit w = - isDigitByte w || (w >= 0x41 && w <= 0x46) || (w >= 0x61 && w <= 0x66) - --- | An ASCII letter. -{-# INLINE isAsciiAlpha #-} -isAsciiAlpha :: Word8 -> Bool -isAsciiAlpha w = (w >= 0x41 && w <= 0x5A) || (w >= 0x61 && w <= 0x7A) - --- | Numeric value of a hex digit. Requires 'isHexDigit'; other inputs give --- unspecified results. -{-# INLINE hexValue #-} -hexValue :: Word8 -> Word8 -hexValue w - | isDigitByte w = w - 0x30 - | otherwise = lower w - 0x61 + 10 - --- | Lowercase an ASCII letter; leave other bytes unchanged. -{-# INLINE lower #-} -lower :: Word8 -> Word8 -lower w = if w >= 0x41 && w <= 0x5A then w .|. 0x20 else w - --- | ASCII lowercase. Returns the original buffer if no uppercase letters --- occur; otherwise copies it. Intended for case-insensitive names. -lowercase :: ByteString -> ByteString -lowercase s - | BS.all (\w -> w < 0x41 || w > 0x5A) s = s - | otherwise = BS.map lower s - --------------------------------------------------------------------------------- --- Whitespace --------------------------------------------------------------------------------- - --- | Skip whitespace. -skipWsp :: P () -skipWsp = skipWhileByte isWsp -{-# INLINE skipWsp #-} - --- | Skip any sequence of whitespace and commas, including repeated commas. -skipWspComma :: P () -skipWspComma = skipWhileByte \w -> isWsp w || w == 0x2C -{-# INLINE skipWspComma #-} - --- | Drop the whitespace either side of a value. -strip :: ByteString -> ByteString -strip = BS.dropWhile isWsp . BS.dropWhileEnd isWsp - --------------------------------------------------------------------------------- --- Numbers --------------------------------------------------------------------------------- - --- | Clamp to [0, 1]. -{-# INLINE clamp01 #-} -clamp01 :: Float -> Float -clamp01 = max 0 . min 1 diff --git a/lib/Graphics/NanoSvg/Number.hs b/lib/Graphics/NanoSvg/Number.hs deleted file mode 100644 --- a/lib/Graphics/NanoSvg/Number.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Graphics.NanoSvg.Number --- Copyright : (c) 2026 goolord --- License : MIT --- --- Parse SVG numbers, lengths and coordinate lists. --- --- Numbers accept an optional sign, decimal point and exponent, including --- @.5@, @1.@, @1e3@ and @-.5E-3@. Nonfinite results are rejected. --- --- Absolute lengths convert at 96 user units per inch. Relative units --- (@%@, @em@, @ex@) are parsed but 'toUserUnits' returns 'Nothing' for them. -module Graphics.NanoSvg.Number - ( -- * Numbers - number - , parseNumber - - -- * Lengths - , Unit (..) - , Length (..) - , length_ - , parseLength - , toUserUnits - , parseUserUnits - - -- * Lists - , numberList - , parseNumberList - , coordinatePair - , pointList - , parsePointList - - -- * Flags - , flag - ) -where - -import Data.ByteString (ByteString) -import Data.Primitive.PrimArray (PrimArray, indexPrimArray, primArrayFromList) -import FlatParse.Basic qualified as F -import GHC.Float (double2Float) -import Graphics.NanoSvg.Internal.Parser -import Graphics.NanoSvg.Types (Point (..)) - --------------------------------------------------------------------------------- --- Numbers --------------------------------------------------------------------------------- - --- | Parse one finite SVG number without leading whitespace. --- An incomplete exponent is left unconsumed; underflow may produce zero. -number :: P Float -number = do - negative <- sign - -- The integer part, then the fraction. Either may be empty, but not both. - whole <- digits False (Acc 0 0 0) - Acc m n e <- (dot *> digits True whole) F.<|> pure whole - if n == 0 - then F.failed - else do - -- An @e@ with no digits after it belongs to whatever follows, as in - -- the @1ex@ of a length, so the exponent backtracks as a whole. - e' <- (exponentMark *> exponentValue) F.<|> pure 0 - let !x = assemble negative m (e + e') - -- Reject overflow and NaN, including 0e400 (zero times infinity). - if isNaN x || isInfinite x then F.failed else pure x - where - dot = skipSatisfyByte (== 0x2E) - exponentMark = skipSatisfyByte (\w -> w == 0x65 || w == 0x45) - --- | Mantissa, digit count and decimal exponent. -data Acc = Acc {-# UNPACK #-} !Word {-# UNPACK #-} !Int {-# UNPACK #-} !Int - --- | Accumulate digits up to 'mantissaLimit'. Further integer digits increase --- the exponent; further fractional digits are discarded. -{-# INLINE digits #-} -digits :: Bool -> Acc -> P Acc -digits !fractional = go - where - go acc@(Acc m n e) = - F.withOption - (satisfyByte isDigitByte) - ( \w -> - let !d = fromIntegral (w - 0x30) - in go - if m < mantissaLimit - then Acc (m * 10 + d) (n + 1) (if fractional then e - 1 else e) - else Acc m (n + 1) (if fractional then e else e + 1) - ) - (pure acc) - --- | Mantissa accumulation limit, retaining more precision than 'Float' needs. -mantissaLimit :: Word -mantissaLimit = 100000000000000000 - --- | A leading @-@ or @+@, and whether it was a minus. -sign :: P Bool -sign = - F.withOption - (satisfyByte (\w -> w == 0x2D || w == 0x2B)) - (\w -> pure (w == 0x2D)) - (pure False) -{-# INLINE sign #-} - --- | The digits of an exponent, with their sign. An @e@ with nothing usable --- after it is not an exponent, and the number ends before it. -exponentValue :: P Int -exponentValue = do - negative <- sign - Acc m n _ <- digits False (Acc 0 0 0) - if n == 0 - then F.failed - else pure $! (if negative then negate else id) (fromIntegral (min 10000 m)) - --- | Scale in 'Double', then narrow to 'Float'. 'number' rejects nonfinite --- results from either step. -assemble :: Bool -> Word -> Int -> Float -assemble negative m e = double2Float (if negative then negate d else d) - where - d = fromIntegral m * powerOfTen e :: Double - -powerOfTen :: Int -> Double -powerOfTen e - | e >= 0, e <= 22 = indexPrimArray tenTable e - | e < 0, e >= -22 = 1 / indexPrimArray tenTable (negate e) - | otherwise = 10 ** fromIntegral e - --- | @10 ^ k@ for @k@ up to 22, the largest power of ten a 'Double' holds --- exactly. -tenTable :: PrimArray Double -tenTable = primArrayFromList [10 ^ k | k <- [0 :: Int .. 22]] -{-# NOINLINE tenTable #-} - --- | Parse one complete number with optional surrounding whitespace. --- Returns 'Nothing' for invalid input, trailing content or nonfinite results. -parseNumber :: ByteString -> Maybe Float -parseNumber src = evaluate src (skipWsp *> number <* skipWsp) - --------------------------------------------------------------------------------- --- Lengths --------------------------------------------------------------------------------- - --- | The unit a length was written in. -data Unit - = -- | No unit: already user units. - UserSpace - | -- | @px@, which SVG defines as one user unit. - Px - | -- | @pt@: 1\/72 inch. - Pt - | -- | @pc@: 1\/6 inch. - Pc - | -- | @in@. - Inch - | -- | @cm@. - Cm - | -- | @mm@. - Mm - | -- | @em@: relative to the font size. - Em - | -- | @ex@: relative to the x-height. - Ex - | -- | @%@: relative to the viewport. - Percent - deriving (Eq, Show) - --- | A number and its unit. -data Length = Length {-# UNPACK #-} !Float !Unit - deriving (Eq, Show) - --- | Parse a number and optional unit without leading whitespace. --- Unit suffixes are case-insensitive and must immediately follow the number. -length_ :: P Length -length_ = Length <$> number <*> (unit F.<|> pure UserSpace) - where - unit = - F.withAnyWord8 \a -> case a of - 0x25 -> pure Percent - _ -> - F.withAnyWord8 \b -> case (lower a, lower b) of - (0x70, 0x78) -> pure Px -- px - (0x70, 0x74) -> pure Pt -- pt - (0x70, 0x63) -> pure Pc -- pc - (0x69, 0x6E) -> pure Inch -- in - (0x63, 0x6D) -> pure Cm -- cm - (0x6D, 0x6D) -> pure Mm -- mm - (0x65, 0x6D) -> pure Em -- em - (0x65, 0x78) -> pure Ex -- ex - _ -> F.failed - --- | Parse one complete length with optional surrounding whitespace. --- Unknown units or trailing content return 'Nothing'. -parseLength :: ByteString -> Maybe Length -parseLength src = evaluate src (skipWsp *> length_ <* skipWsp) - --- | Convert at 96 user units per inch. Returns 'Nothing' for 'Em', 'Ex' and --- 'Percent', which require font or viewport context. -toUserUnits :: Length -> Maybe Float -toUserUnits (Length x u) = case u of - UserSpace -> Just x - Px -> Just x - Pt -> Just (x * 96 / 72) - Pc -> Just (x * 16) - Inch -> Just (x * 96) - Cm -> Just (x * 96 / 2.54) - Mm -> Just (x * 96 / 25.4) - Em -> Nothing - Ex -> Nothing - Percent -> Nothing - --- | 'parseLength' followed by 'toUserUnits'. -parseUserUnits :: ByteString -> Maybe Float -parseUserUnits src = parseLength src >>= toUserUnits - --------------------------------------------------------------------------------- --- Lists --------------------------------------------------------------------------------- - --- | Numbers separated by whitespace and commas, stopping at the first thing --- that is not a number. -numberList :: P [Float] -numberList = skipWspComma *> go - where - go = F.withOption number (\x -> (x :) <$> (skipWspComma *> go)) (pure []) - --- | Parse the initial number list, ignoring any malformed tail. --- Returns @[]@ if no number can be read. -parseNumberList :: ByteString -> [Float] -parseNumberList src = maybe [] fst (runPartial src numberList) - --- | Two numbers, which may be separated by a comma, whitespace, or in the --- case of @1-2@ or @1.5.5@ by nothing at all. -coordinatePair :: P Point -coordinatePair = do - x <- number - skipWspComma - y <- number - pure (Point x y) -{-# INLINE coordinatePair #-} - --- | Parse coordinate pairs separated by whitespace or commas. --- Stops before an incomplete pair or malformed tail. -pointList :: P [Point] -pointList = skipWspComma *> go - where - go = F.withOption coordinatePair (\p -> (p :) <$> (skipWspComma *> go)) (pure []) - --- | Parse a @points@ attribute. Keeps complete pairs before a malformed tail --- and drops an unmatched final coordinate. -parsePointList :: ByteString -> [Point] -parsePointList src = maybe [] fst (runPartial src pointList) - --------------------------------------------------------------------------------- --- Flags --------------------------------------------------------------------------------- - --- | An arc flag: a single @0@ or @1@, which may run straight into the --- number after it, as in @a1 1 0 00.5.5@. -flag :: P Bool -flag = satisfyByte (\w -> w == 0x30 || w == 0x31) >>= \w -> pure (w == 0x31) -{-# INLINE flag #-} diff --git a/lib/Graphics/NanoSvg/Path.hs b/lib/Graphics/NanoSvg/Path.hs deleted file mode 100644 --- a/lib/Graphics/NanoSvg/Path.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Graphics.NanoSvg.Path --- Copyright : (c) 2026 goolord --- License : MIT --- --- Parse path data and transforms, and convert basic SVG shapes to paths. --- --- Paths use absolute 'Segment's. Parsing resolves relative coordinates, --- @H@, @V@, @S@, @T@ and implicit command repetition. Renderers still track --- the current point and subpath start; transforms are returned separately. --- --- Malformed path data retains the complete segments before the error. -module Graphics.NanoSvg.Path - ( -- * Path data - pathData - , parsePath - - -- * Transforms - , transformList - , parseTransform - - -- * The shape elements - , rectSegments - , circleSegments - , ellipseSegments - , lineSegments - , polySegments - ) -where - -import Control.Applicative ((<|>)) -import Data.ByteString (ByteString) -import Data.Maybe (fromMaybe) -import Data.Word (Word8) -import FlatParse.Basic qualified as F -import Graphics.NanoSvg.Internal.Parser -import Graphics.NanoSvg.Number (coordinatePair, flag, number, numberList) -import Graphics.NanoSvg.Types - --------------------------------------------------------------------------------- --- Path data --------------------------------------------------------------------------------- - --- | The @d@ attribute of a @path@, as absolute segments. --- --- Always succeeds, stopping at the first unknown or incomplete command. -pathData :: P [Segment] -pathData = walk (St 0x4D origin origin NoCtrl) - where - origin = Point 0 0 - --- | Parse a @d@ attribute into absolute segments. Ignores a malformed tail; --- returns @[]@ when no complete segment can be read. -parsePath :: ByteString -> [Segment] -parsePath src = maybe [] fst (runPartial src pathData) - --- | State carried between path commands. -data St = St - { stCommand :: !Word8 - -- ^ The command to repeat when a run of arguments follows. - , stCurrent :: !Point - , stSubpath :: !Point - -- ^ Where the open subpath began, for @Z@. - , stControl :: !Ctrl - } - --- | Previous control point: @S@ reflects only a cubic control point and @T@ --- only a quadratic one. Otherwise, the current point is used. -data Ctrl = NoCtrl | CubicCtrl !Point | QuadCtrl !Point - -walk :: St -> P [Segment] -walk st = do - skipWspComma - peekByte >>= \case - Nothing -> pure [] - Just w - | isAsciiAlpha w -> F.skip 1 *> skipWspComma *> step st {stCommand = w} - -- A run of arguments repeats the command that introduced it. - | otherwise -> step st - --- | Read one argument group, stopping the path if it is incomplete. -step :: St -> P [Segment] -step st@(St cmd current@(Point cx cy) subpath ctrl) = case lower cmd of - 0x6D -> ending do - -- m: moveto - p <- point - -- A second pair after a moveto is a lineto, and a relative moveto - -- makes them relative linetos. - (MoveTo p :) - <$> walk - st - { stCommand = if relative then 0x6C else 0x4C - , stCurrent = p - , stSubpath = p - , stControl = NoCtrl - } - 0x6C -> ending do - -- l: lineto - p <- point - (LineTo p :) <$> continue p NoCtrl - 0x68 -> ending do - -- h: horizontal lineto - x <- number - let p = Point (if relative then cx + x else x) cy - (LineTo p :) <$> continue p NoCtrl - 0x76 -> ending do - -- v: vertical lineto - y <- number - let p = Point cx (if relative then cy + y else y) - (LineTo p :) <$> continue p NoCtrl - 0x63 -> ending do - -- c: curveto - c1 <- point - skipWspComma - c2 <- point - skipWspComma - p <- point - (CubicTo c1 c2 p :) <$> continue p (CubicCtrl c2) - 0x73 -> ending do - -- s: smooth curveto - c2 <- point - skipWspComma - p <- point - let c1 = case ctrl of - CubicCtrl q -> reflect current q - _ -> current - (CubicTo c1 c2 p :) <$> continue p (CubicCtrl c2) - 0x71 -> ending do - -- q: quadratic curveto - c1 <- point - skipWspComma - p <- point - (QuadTo c1 p :) <$> continue p (QuadCtrl c1) - 0x74 -> ending do - -- t: smooth quadratic curveto - p <- point - let c1 = case ctrl of - QuadCtrl q -> reflect current q - _ -> current - (QuadTo c1 p :) <$> continue p (QuadCtrl c1) - 0x61 -> ending do - -- a: elliptical arc - rx <- number - skipWspComma - ry <- number - skipWspComma - rot <- number - skipWspComma - -- Single-digit flags need no separators: a1 1 0 00.5.5 has seven arguments. - large <- flag - skipWspComma - sweep <- flag - skipWspComma - p <- point - (ArcTo (abs rx) (abs ry) rot large sweep p :) <$> continue p NoCtrl - 0x7A -> - -- z: closepath. The current point returns to where the subpath began, - -- and a bare coordinate pair after it starts a new one. - (ClosePath :) - <$> walk - st - { stCommand = if relative then 0x6D else 0x4D - , stCurrent = subpath - , stControl = NoCtrl - } - _ -> pure [] -- Not a command: the path ends. - where - relative = cmd >= 0x61 - point = do - Point x y <- coordinatePair - pure (if relative then Point (cx + x) (cy + y) else Point x y) - continue p c = walk st {stCurrent = p, stControl = c} - reflect (Point x y) (Point qx qy) = Point (2 * x - qx) (2 * y - qy) - ending p = F.withOption p pure (pure []) - --------------------------------------------------------------------------------- --- Transforms --------------------------------------------------------------------------------- - --- | Compose a transform list in SVG order; the rightmost transform acts first. --- --- Always succeeds. Unknown functions or wrong argument counts contribute --- identity if their numeric argument list parses. Malformed syntax ends --- the list, retaining the transforms already read. -transformList :: P Matrix -transformList = skipWspComma *> go identity - where - go m = F.withOption transformItem (\m' -> go (m `multiply` m')) (pure m) - --- | Parse a @transform@ attribute using 'transformList'. Returns 'identity' --- when no usable transform is read. -parseTransform :: ByteString -> Matrix -parseTransform src = maybe identity fst (runPartial src transformList) - -transformItem :: P Matrix -transformItem = do - name <- takeWhileByte isAsciiAlpha - skipWsp - skipSatisfyByte (== 0x28) - args <- numberList - skipWsp - skipSatisfyByte (== 0x29) - skipWspComma - pure case name of - "matrix" | [a, b, c, d, e, f] <- args -> Matrix a b c d e f - "translate" -> case args of - [x] -> translation x 0 - [x, y] -> translation x y - _ -> identity - "scale" -> case args of - [k] -> scaling k k - [sx, sy] -> scaling sx sy - _ -> identity - "rotate" -> case args of - [a] -> rotation a - [a, cx, cy] -> - translation cx cy `multiply` rotation a `multiply` translation (-cx) (-cy) - _ -> identity - "skewX" | [a] <- args -> Matrix 1 0 (tan (radians a)) 1 0 0 - "skewY" | [a] <- args -> Matrix 1 (tan (radians a)) 0 1 0 0 - _ -> identity - where - radians a = a * pi / 180 - --------------------------------------------------------------------------------- --- The shape elements --------------------------------------------------------------------------------- - --- | @rectSegments x y width height rx ry@ constructs a closed rectangle. --- Missing corner radii default to each other, or zero if both are absent. --- Radii are made nonnegative and capped at half the corresponding side. --- Nonpositive width or height returns @[]@. -rectSegments :: - Float -> Float -> Float -> Float -> Maybe Float -> Maybe Float -> [Segment] -rectSegments x y w h mrx mry - | w <= 0 || h <= 0 = [] - | rx <= 0 || ry <= 0 = - [ MoveTo (Point x y) - , LineTo (Point (x + w) y) - , LineTo (Point (x + w) (y + h)) - , LineTo (Point x (y + h)) - , ClosePath - ] - | otherwise = - [ MoveTo (Point (x + rx) y) - , LineTo (Point (x + w - rx) y) - , corner (Point (x + w) (y + ry)) - , LineTo (Point (x + w) (y + h - ry)) - , corner (Point (x + w - rx) (y + h)) - , LineTo (Point (x + rx) (y + h)) - , corner (Point x (y + h - ry)) - , LineTo (Point x (y + ry)) - , corner (Point (x + rx) y) - , ClosePath - ] - where - rx = min (w / 2) (abs (fromMaybe 0 (mrx <|> mry))) - ry = min (h / 2) (abs (fromMaybe 0 (mry <|> mrx))) - -- A quarter ellipse, the short way round, clockwise on screen. - corner = ArcTo rx ry 0 False True - --- | @circleSegments cx cy radius@ constructs a closed circle from two arcs. --- A nonpositive radius returns @[]@. -circleSegments :: Float -> Float -> Float -> [Segment] -circleSegments cx cy r = ellipseSegments cx cy r r - --- | @ellipseSegments cx cy rx ry@ constructs a closed ellipse from two arcs. --- Either radius being nonpositive returns @[]@. -ellipseSegments :: Float -> Float -> Float -> Float -> [Segment] -ellipseSegments cx cy rx ry - | rx <= 0 || ry <= 0 = [] - | otherwise = - [ MoveTo (Point (cx + rx) cy) - , ArcTo rx ry 0 False True (Point (cx - rx) cy) - , ArcTo rx ry 0 False True (Point (cx + rx) cy) - , ClosePath - ] - --- | @lineSegments x1 y1 x2 y2@ constructs an open line between two endpoints. -lineSegments :: Float -> Float -> Float -> Float -> [Segment] -lineSegments x1 y1 x2 y2 = [MoveTo (Point x1 y1), LineTo (Point x2 y2)] - --- | Connect points with straight lines. 'True' appends 'ClosePath' for a --- polygon; 'False' produces an open polyline. An empty input returns @[]@. -polySegments :: Bool -> [Point] -> [Segment] -polySegments closed = \case - [] -> [] - p : ps -> MoveTo p : map LineTo ps <> [ClosePath | closed] diff --git a/lib/Graphics/NanoSvg/Types.hs b/lib/Graphics/NanoSvg/Types.hs --- a/lib/Graphics/NanoSvg/Types.hs +++ b/lib/Graphics/NanoSvg/Types.hs @@ -1,362 +1,165 @@ -{-# LANGUAGE DerivingStrategies #-} - --- | --- Module : Graphics.NanoSvg.Types --- Copyright : (c) 2026 goolord --- License : MIT --- --- The flattened document model used by "Graphics.NanoSvg". --- --- A t'Document' holds t'Shape's in paint order. Each shape has a path in local --- coordinates, a t'Matrix' mapping it into the document viewBox, and a --- resolved t'Style'. Viewport mapping and rendering are the caller's job. -module Graphics.NanoSvg.Types - ( -- * Colors - RGBA (..) - , rgba - , rgbaR - , rgbaG - , rgbaB - , rgbaA - , withAlpha - , black - , transparent - - -- * Geometry - , Point (..) - , Box (..) - - -- * Transforms - , Matrix (..) - , identity - , multiply - , translation - , scaling - , rotation - , transformPoint - , averageScale - - -- * Path segments - , Segment (..) - - -- * Paint - , Paint (..) - , FillRule (..) - , LineCap (..) - , LineJoin (..) - , Style (..) - , defaultStyle - - -- * Shapes - , Shape (..) - - -- * Documents - , Document (..) - , documentWidth - , documentHeight - ) -where - -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import Data.Char (intToDigit) -import Data.Primitive.SmallArray (SmallArray) -import Data.Word (Word32, Word8) - --------------------------------------------------------------------------------- --- Colors --------------------------------------------------------------------------------- - --- | An opaque or translucent color, packed as @0xRRGGBBAA@. --- Channels are not premultiplied by alpha. -newtype RGBA = RGBA {rgbaToWord32 :: Word32} - deriving newtype (Eq, Ord) - --- | Shown as @#rrggbbaa@. -instance Show RGBA where - show c = '#' : concatMap hex2 [rgbaR c, rgbaG c, rgbaB c, rgbaA c] - where - hex2 w = [digit (w `shiftR` 4), digit (w .&. 0xF)] - digit = intToDigit . fromIntegral - --- | Pack red, green, blue and alpha. Alpha 0 is transparent, 255 opaque. -{-# INLINE rgba #-} -rgba :: Word8 -> Word8 -> Word8 -> Word8 -> RGBA -rgba r g b a = - RGBA $ - (w32 r `shiftL` 24) - .|. (w32 g `shiftL` 16) - .|. (w32 b `shiftL` 8) - .|. w32 a - where - w32 = fromIntegral :: Word8 -> Word32 - --- | The red channel. -{-# INLINE rgbaR #-} -rgbaR :: RGBA -> Word8 -rgbaR (RGBA w) = fromIntegral (w `shiftR` 24) - --- | The green channel. -{-# INLINE rgbaG #-} -rgbaG :: RGBA -> Word8 -rgbaG (RGBA w) = fromIntegral (w `shiftR` 16) - --- | The blue channel. -{-# INLINE rgbaB #-} -rgbaB :: RGBA -> Word8 -rgbaB (RGBA w) = fromIntegral (w `shiftR` 8) - --- | The alpha channel. -{-# INLINE rgbaA #-} -rgbaA :: RGBA -> Word8 -rgbaA (RGBA w) = fromIntegral w - --- | The color with its alpha replaced. -{-# INLINE withAlpha #-} -withAlpha :: Word8 -> RGBA -> RGBA -withAlpha a (RGBA w) = RGBA ((w .&. 0xFFFFFF00) .|. fromIntegral a) - --- | Opaque black, the initial value of @fill@. -black :: RGBA -black = rgba 0 0 0 255 - --- | Zero in every channel. -transparent :: RGBA -transparent = RGBA 0 - --------------------------------------------------------------------------------- --- Geometry --------------------------------------------------------------------------------- - --- | A point in user space. -data Point = Point {-# UNPACK #-} !Float {-# UNPACK #-} !Float - deriving stock (Eq, Show) - --- | A rectangle as @x y width height@, the shape of a @viewBox@. -data Box = Box - { boxX :: {-# UNPACK #-} !Float - , boxY :: {-# UNPACK #-} !Float - , boxW :: {-# UNPACK #-} !Float - , boxH :: {-# UNPACK #-} !Float - } - deriving stock (Eq, Show) - --------------------------------------------------------------------------------- --- Transforms --------------------------------------------------------------------------------- - --- | SVG affine transform @matrix(a b c d e f)@: --- --- > | a c e | --- > | b d f | --- > | 0 0 1 | --- --- Maps @(x, y)@ to @(a*x + c*y + e, b*x + d*y + f)@. -data Matrix = Matrix - { matrixA :: {-# UNPACK #-} !Float - , matrixB :: {-# UNPACK #-} !Float - , matrixC :: {-# UNPACK #-} !Float - , matrixD :: {-# UNPACK #-} !Float - , matrixE :: {-# UNPACK #-} !Float - , matrixF :: {-# UNPACK #-} !Float - } - deriving stock (Eq, Show) - --- | Identity transform. -identity :: Matrix -identity = Matrix 1 0 0 1 0 0 - --- | Compose transforms: @multiply outer inner@ applies @inner@ first. -{-# INLINE multiply #-} -multiply :: Matrix -> Matrix -> Matrix -multiply (Matrix a b c d e f) (Matrix a' b' c' d' e' f') = - Matrix - (a * a' + c * b') - (b * a' + d * b') - (a * c' + c * d') - (b * c' + d * d') - (a * e' + c * f' + e) - (b * e' + d * f' + f) - --- | @translate(x, y)@. -{-# INLINE translation #-} -translation :: Float -> Float -> Matrix -translation x y = Matrix 1 0 0 1 x y - --- | @scale(sx, sy)@. -{-# INLINE scaling #-} -scaling :: Float -> Float -> Matrix -scaling sx sy = Matrix sx 0 0 sy 0 0 - --- | @rotate(a)@, the angle in degrees, clockwise because y points down. -{-# INLINE rotation #-} -rotation :: Float -> Matrix -rotation deg = - let r = deg * pi / 180 - s = sin r - c = cos r - in Matrix c s (negate s) c 0 0 - --- | Map a point through a transform. -{-# INLINE transformPoint #-} -transformPoint :: Matrix -> Point -> Point -transformPoint (Matrix a b c d e f) (Point x y) = - Point (a * x + c * y + e) (b * x + d * y + f) - --- | Square root of the absolute determinant. Exact as a length scale for --- uniform scaling; an area-based approximation for nonuniform scaling or --- shear. Useful when a renderer represents stroke width with one scalar. -{-# INLINE averageScale #-} -averageScale :: Matrix -> Float -averageScale (Matrix a b c d _ _) = sqrt (abs (a * d - b * c)) - --------------------------------------------------------------------------------- --- Path segments --------------------------------------------------------------------------------- - --- | A path command in absolute, shape-local coordinates. Relative commands --- and shorthands are resolved during parsing; 'shapeTransform' is not baked --- into the points. A renderer still tracks the current point and subpath start. -data Segment - = -- | Start a new subpath. - MoveTo !Point - | -- | Straight line to a point. - LineTo !Point - | -- | Cubic Bezier: first control point, second control point, endpoint. - CubicTo !Point !Point !Point - | -- | Quadratic Bezier: control point, endpoint. - QuadTo !Point !Point - | -- | Elliptical arc: radii, the x-axis rotation in degrees, the - -- large-arc and sweep flags, and the endpoint. - ArcTo - {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - {-# UNPACK #-} !Float - !Bool - !Bool - !Point - | -- | Close the current subpath back to where it started. - ClosePath - deriving stock (Eq, Show) - --------------------------------------------------------------------------------- --- Paint --------------------------------------------------------------------------------- - --- | What fills or strokes a shape. -data Paint - = -- | @none@: draw nothing. - PaintNone - | -- | @currentColor@: a color supplied by the renderer. - PaintCurrent - | -- | A literal color. - PaintColor !RGBA - deriving stock (Eq, Show) - --- | Rule for determining a path's filled interior. -data FillRule = NonZero | EvenOdd - deriving stock (Eq, Show) - --- | Stroke endpoint shape. -data LineCap = CapButt | CapRound | CapSquare - deriving stock (Eq, Show) - --- | Stroke corner shape. -data LineJoin = JoinMiter | JoinRound | JoinBevel - deriving stock (Eq, Show) - --- | Resolved presentation properties in shape-local units. --- --- An unset fill is distinct from explicit black so a renderer can apply an --- icon tint. Without a tint, use SVG's default black fill. The default stroke --- is 'Just' 'PaintNone'. See 'defaultStyle' and 'documentMonochrome'. -data Style = Style - { styleFill :: !(Maybe Paint) - -- ^ Fill paint; 'Nothing' means unspecified. - , styleStroke :: !(Maybe Paint) - -- ^ Stroke paint; 'Nothing' means unspecified. - , styleStrokeWidth :: {-# UNPACK #-} !Float - -- ^ Stroke width before 'shapeTransform' is applied. - , styleCap :: !LineCap - , styleJoin :: !LineJoin - , styleMiterLimit :: {-# UNPACK #-} !Float - -- ^ Maximum miter length as a multiple of stroke width. - , styleFillRule :: !FillRule - , styleOpacity :: {-# UNPACK #-} !Float - -- ^ Local opacity multiplied by ancestor opacities. This does not preserve - -- SVG group compositing for overlapping shapes. - , styleFillOpacity :: {-# UNPACK #-} !Float - -- ^ Fill opacity, multiplied with paint alpha and 'styleOpacity' when drawn. - , styleStrokeOpacity :: {-# UNPACK #-} !Float - -- ^ Stroke opacity, multiplied with paint alpha and 'styleOpacity' when drawn. - } - deriving stock (Eq, Show) - --- | Initial style: unset fill, no stroke, width 1, butt caps, miter joins, --- miter limit 4, nonzero fill rule and full opacity. -defaultStyle :: Style -defaultStyle = - Style - { styleFill = Nothing - , styleStroke = Just PaintNone - , styleStrokeWidth = 1 - , styleCap = CapButt - , styleJoin = JoinMiter - , styleMiterLimit = 4 - , styleFillRule = NonZero - , styleOpacity = 1 - , styleFillOpacity = 1 - , styleStrokeOpacity = 1 - } - --------------------------------------------------------------------------------- --- Shapes --------------------------------------------------------------------------------- - --- | One drawable path. -data Shape = Shape - { shapeSegments :: !(SmallArray Segment) - -- ^ Absolute segments in the shape's own coordinates. - , shapeTransform :: !Matrix - -- ^ From those coordinates into the document's 'documentViewBox'. - , shapeStyle :: !Style - -- ^ Presentation properties after inheritance and local declarations. - } - deriving stock (Eq, Show) - --------------------------------------------------------------------------------- --- Documents --------------------------------------------------------------------------------- - --- | A parsed SVG document. Equality compares only 'documentKey', not geometry. -data Document = Document - { documentViewBox :: !Box - -- ^ Root @viewBox@ when valid. Otherwise, a box at the origin using root - -- dimensions, with 24 for each missing or unresolvable dimension. - , documentSize :: {-# UNPACK #-} !(Float, Float) - -- ^ Requested width and height in user units. Each unresolved root - -- dimension falls back to the corresponding 'documentViewBox' extent. - , documentShapes :: !(SmallArray Shape) - -- ^ Every shape, in paint order. - , documentKey :: {-# UNPACK #-} !Int - -- ^ FNV-1a hash of the source bytes, converted to 'Int'. A cache hint, not - -- a collision-free identifier; its width depends on the platform. - , documentMonochrome :: !Bool - -- ^ No shape has a literal 'PaintColor'. Unset paints, 'PaintNone' and - -- 'PaintCurrent' allow caller tinting. Explicit black counts as a literal - -- color; an empty document is monochrome. - } - --- | Documents are equal when their sources hash the same. -instance Eq Document where - a == b = documentKey a == documentKey b - -instance Show Document where - show doc = " show (documentSize doc) <> ">" - --- | The width the document asks to be drawn at. -documentWidth :: Document -> Float -documentWidth = fst . documentSize - --- | The height the document asks to be drawn at. -documentHeight :: Document -> Float -documentHeight = snd . documentSize +{-# LANGUAGE DerivingStrategies #-} + +-- | +-- Module : Graphics.NanoSvg.Types +-- Copyright : (c) 2026 goolord +-- License : MIT +-- +-- The flattened document model: shapes in paint order, each with absolute +-- segments, a transform into the viewBox and a resolved style. +module Graphics.NanoSvg.Types + ( -- * Colors + RGBA (..) + , rgba + , black + + -- * Geometry + , Point (..) + , Box (..) + , Matrix (..) + , identity + , multiply + , translate + , transformPoint + , averageScale + + -- * Shapes + , Segment (..) + , Paint (..) + , FillRule (..) + , LineCap (..) + , LineJoin (..) + , Style (..) + , defaultStyle + , Shape (..) + , Document (..) + ) +where + +import Data.Primitive.SmallArray (SmallArray) +import Data.Word (Word32, Word8) +import Text.Printf (printf) + +-- | A color packed as @0xRRGGBBAA@, not premultiplied. Shown as @#rrggbbaa@. +newtype RGBA = RGBA {rgbaToWord32 :: Word32} + deriving newtype (Eq, Ord) + +instance Show RGBA where + show (RGBA w) = printf "#%08x" w + +-- | Pack red, green, blue and alpha; alpha 255 is opaque. +rgba :: Word8 -> Word8 -> Word8 -> Word8 -> RGBA +rgba r g b a = RGBA (foldl' (\acc c -> acc * 256 + fromIntegral c) 0 [r, g, b, a]) + +-- | Opaque black, the initial value of @fill@. +black :: RGBA +black = rgba 0 0 0 255 + +data Point = Point !Float !Float + deriving stock (Eq, Show) + +-- | A @viewBox@. +data Box = Box {boxX, boxY, boxW, boxH :: !Float} + deriving stock (Eq, Show) + +-- | @matrix(a b c d e f)@, mapping @(x, y)@ to @(a*x + c*y + e, b*x + d*y + f)@. +data Matrix = Matrix {matrixA, matrixB, matrixC, matrixD, matrixE, matrixF :: !Float} + deriving stock (Eq, Show) + +identity :: Matrix +identity = Matrix 1 0 0 1 0 0 + +-- | @multiply outer inner@ applies @inner@ first. +multiply :: Matrix -> Matrix -> Matrix +multiply (Matrix a b c d e f) (Matrix a' b' c' d' e' f') = + Matrix (a * a' + c * b') (b * a' + d * b') (a * c' + c * d') (b * c' + d * d') (a * e' + c * f' + e) (b * e' + d * f' + f) + +transformPoint :: Matrix -> Point -> Point +transformPoint (Matrix a b c d e f) (Point x y) = Point (a * x + c * y + e) (b * x + d * y + f) + +-- | Square root of the absolute determinant: a single scale factor for +-- stroke widths, exact for uniform scaling. +averageScale :: Matrix -> Float +averageScale (Matrix a b c d _ _) = sqrt (abs (a * d - b * c)) + +-- | @translate(x, y)@. +translate :: Float -> Float -> Matrix +translate = Matrix 1 0 0 1 + +-- | A path command in absolute, shape-local coordinates. A renderer still +-- tracks the current point and subpath start. +data Segment + = MoveTo !Point + | LineTo !Point + | -- | Two control points and the endpoint. + CubicTo !Point !Point !Point + | -- | Control point and endpoint. + QuadTo !Point !Point + | -- | Radii, x-axis rotation in degrees, large-arc and sweep flags, endpoint. + ArcTo !Float !Float !Float !Bool !Bool !Point + | ClosePath + deriving stock (Eq, Show) + +-- | 'PaintCurrent' is @currentColor@; @none@ and @transparent@ are 'PaintNone'. +data Paint = PaintNone | PaintCurrent | PaintColor !RGBA + deriving stock (Eq, Show) + +data FillRule = NonZero | EvenOdd + deriving stock (Eq, Show) + +data LineCap = CapButt | CapRound | CapSquare + deriving stock (Eq, Show) + +data LineJoin = JoinMiter | JoinRound | JoinBevel + deriving stock (Eq, Show) + +-- | Resolved presentation properties. An unset ('Nothing') fill is distinct +-- from black so a renderer can tint icons; see 'documentMonochrome'. +data Style = Style + { styleFill :: !(Maybe Paint) + , styleStroke :: !(Maybe Paint) + , styleStrokeWidth :: !Float + -- ^ Before 'shapeTransform' is applied. + , styleCap :: !LineCap + , styleJoin :: !LineJoin + , styleMiterLimit :: !Float + , styleFillRule :: !FillRule + , styleOpacity :: !Float + -- ^ Multiplied down the tree, not composited as a group. + , styleFillOpacity :: !Float + , styleStrokeOpacity :: !Float + } + deriving stock (Eq, Show) + +-- | Unset fill, no stroke, width 1, butt caps, miter joins, miter limit 4, +-- nonzero fill rule and full opacity. +defaultStyle :: Style +defaultStyle = Style Nothing (Just PaintNone) 1 CapButt JoinMiter 4 NonZero 1 1 1 + +data Shape = Shape + { shapeSegments :: !(SmallArray Segment) + , shapeTransform :: !Matrix + -- ^ From the segments' coordinates into 'documentViewBox'. + , shapeStyle :: !Style + } + deriving stock (Eq, Show) + +-- | A parsed document. Equality compares only 'documentKey'. +data Document = Document + { documentViewBox :: !Box + -- ^ The root @viewBox@, or else a box of the root size, 24 per missing side. + , documentSize :: !(Float, Float) + -- ^ The root @width@ and @height@, each defaulting to the viewBox's. + , documentShapes :: !(SmallArray Shape) + -- ^ In paint order. + , documentKey :: !Int + -- ^ FNV-1a hash of the source, for caching. + , documentMonochrome :: !Bool + -- ^ No shape has a literal 'PaintColor', so the drawing can be tinted. + } + +instance Eq Document where + a == b = documentKey a == documentKey b + +instance Show Document where + show doc = " show (documentSize doc) <> ">" diff --git a/lib/Graphics/NanoSvg/Xml.hs b/lib/Graphics/NanoSvg/Xml.hs deleted file mode 100644 --- a/lib/Graphics/NanoSvg/Xml.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Graphics.NanoSvg.Xml --- Copyright : (c) 2026 goolord --- License : MIT --- --- Minimal XML element tree backed by @hexml@. --- --- Names and unmodified attribute values share the parsed input buffer. --- SVG-specific preprocessing: --- --- * Replace a DOCTYPE and leading UTF-8 byte-order mark with spaces before --- parsing. This preserves byte offsets, but not line numbers within a --- multiline DOCTYPE. Custom entities are not expanded. --- --- * Strip namespace prefixes without resolving namespace URIs: @svg:path@ --- becomes @path@ and @xlink:href@ becomes @href@. --- --- * Decode the five predefined XML entities and decimal or hexadecimal --- character references in attribute values. --- --- Text nodes, comments and processing instructions are omitted. -module Graphics.NanoSvg.Xml - ( -- * The tree - Element (..) - , Attribute (..) - - -- * Parsing - , parseXml - - -- * Looking things up - , attribute - , descendants - - -- * Pieces - , localName - , decodeEntities - , withoutDoctype - ) -where - -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Builder qualified as B -import Data.ByteString.Char8 qualified as BC -import Data.ByteString.Lazy qualified as BL -import Data.Char (chr) -import Data.Maybe (listToMaybe) -import Graphics.NanoSvg.Internal.Parser (hexValue, isDigitByte, isHexDigit) -import Text.XML.Hexml qualified as Hexml - --------------------------------------------------------------------------------- --- The tree --------------------------------------------------------------------------------- - --- | An element with namespace prefixes removed from its name and attributes. -data Element = Element - { elementName :: !ByteString - , elementAttributes :: ![Attribute] - , elementChildren :: ![Element] - } - deriving (Eq, Show) - --- | An attribute with a local name and entity-decoded UTF-8 value. -data Attribute = Attribute - { attributeName :: !ByteString - , attributeValue :: !ByteString - } - deriving (Eq, Show) - --------------------------------------------------------------------------------- --- Parsing --------------------------------------------------------------------------------- - --- | Parse top-level elements or return a @hexml@ error. Does not require an --- @svg@ root. The returned tree may retain the parsed input buffer. -parseXml :: ByteString -> Either String [Element] -parseXml src = case Hexml.parse (withoutDoctype (withoutBom src)) of - Left err -> Left (BC.unpack err) - Right root -> Right (map element (elements root)) - where - -- hexml exposes processing instructions as elements; filter them out. - elements node = - [n | n <- Hexml.children node, not (BS.isPrefixOf " Element -> Maybe ByteString -attribute k el = listToMaybe [v | Attribute n v <- elementAttributes el, n == k] -{-# INLINE attribute #-} - --- | Every element in the subtree, the root itself first, in document order. -descendants :: Element -> [Element] -descendants el = el : concatMap descendants (elementChildren el) - --------------------------------------------------------------------------------- --- Pieces --------------------------------------------------------------------------------- - --- | Everything after the last colon: @svg:path@ becomes @path@. -localName :: ByteString -> ByteString -localName n = case BS.elemIndexEnd 0x3A n of - Just i -> BS.drop (i + 1) n - Nothing -> n - --- | The document with a leading UTF-8 byte-order mark replaced by spaces. -withoutBom :: ByteString -> ByteString -withoutBom src - | BS.isPrefixOf "\xEF\xBB\xBF" src = " " <> BS.drop 3 src - | otherwise = src - --- | Replace the first DOCTYPE, including its internal subset, with spaces. --- Preserves byte offsets, not line numbers. The scanner counts brackets; --- it does not parse quoted strings or comments inside the declaration. -withoutDoctype :: ByteString -> ByteString -withoutDoctype bytes = case BS.breakSubstring " bytes - (before, rest) -> before <> BS.replicate end 0x20 <> BS.drop end rest - where - end = close (0 :: Int) 0 - -- The subset in brackets may itself contain a '>'. - close !depth !k - | k >= BS.length rest = k - | otherwise = case BS.index rest k of - 0x5B -> close (depth + 1) (k + 1) -- '[' - 0x5D -> close (depth - 1) (k + 1) -- ']' - 0x3E | depth <= 0 -> k + 1 -- '>' - _ -> close depth (k + 1) - --- | Decode predefined XML entities and numeric references to UTF-8. --- Unknown or invalid references are left unchanged. Input without @&@ --- is returned without copying. -decodeEntities :: ByteString -> ByteString -decodeEntities v - | BS.notElem 0x26 v = v - | otherwise = BL.toStrict (B.toLazyByteString (go v)) - where - go s = - let (before, rest) = BS.break (== 0x26) s - in if BS.null rest - then B.byteString before - else case entity rest of - Just (b, after) -> B.byteString before <> b <> go after - -- Preserve unknown or malformed references literally. - Nothing -> B.byteString before <> B.word8 0x26 <> go (BS.drop 1 rest) - --- | One reference at the front of the input, and what is left after it. -entity :: ByteString -> Maybe (B.Builder, ByteString) -entity s - | Just r <- BS.stripPrefix "&" s = Just (B.word8 0x26, r) - | Just r <- BS.stripPrefix "<" s = Just (B.word8 0x3C, r) - | Just r <- BS.stripPrefix ">" s = Just (B.word8 0x3E, r) - | Just r <- BS.stripPrefix """ s = Just (B.word8 0x22, r) - | Just r <- BS.stripPrefix "'" s = Just (B.word8 0x27, r) - | Just r <- BS.stripPrefix "&#x" s = numeric 16 isHexDigit (fromIntegral . hexValue) r - | Just r <- BS.stripPrefix "&#X" s = numeric 16 isHexDigit (fromIntegral . hexValue) r - | Just r <- BS.stripPrefix "&#" s = numeric 10 isDigitByte (fromIntegral . hexValue) r - | otherwise = Nothing - where - numeric base isPart value r = - let ds = BS.takeWhile isPart r - after = BS.drop (BS.length ds) r - code = BS.foldl' (\acc w -> acc * base + value w) (0 :: Int) ds - in if BS.null ds || not (BS.isPrefixOf ";" after) || not (isScalar code) - then Nothing - else Just (B.charUtf8 (chr code), BS.drop 1 after) - -- Reject NUL, surrogates and out-of-range code points before calling chr. - isScalar c = c > 0 && c <= 0x10FFFF && not (c >= 0xD800 && c <= 0xDFFF) diff --git a/nano-svg.cabal b/nano-svg.cabal --- a/nano-svg.cabal +++ b/nano-svg.cabal @@ -1,94 +1,91 @@ -cabal-version: 3.0 -name: nano-svg -version: 0.1.0.0 -synopsis: An SVG parser for icons - -description: - Parse static SVG icons and vector artwork for geometry renderers, - rasterizers and UI toolkits. - - Reads UTF-8 @ByteString@ input using @hexml@ for XML and @flatparse@ - for attribute values. Returns a flat array of shapes in paint order, - each with absolute path segments, a transform and a resolved style. - - Path, transform, color, length and coordinate-list parsers can also be - used independently. Rendering and viewport mapping are left to the caller. - - Gradients, patterns, text, masks, clipping paths, filters and CSS - stylesheets are not supported. See "Graphics.NanoSvg" for supported - features and limitations. - -license: MIT -license-file: LICENSE -author: goolord -maintainer: zacharyachurchill@gmail.com -category: Graphics -build-type: Simple -tested-with: GHC ==9.14.1 -extra-doc-files: - CHANGELOG.md - README.md - -common extensions - default-language: GHC2021 - default-extensions: - BlockArguments - LambdaCase - OverloadedStrings - -common ghc-options - ghc-options: - -Wall - -Widentities - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wmissing-export-lists - -Wmissing-home-modules - -Wpartial-fields - -Wredundant-constraints - -common rts-options - ghc-options: -rtsopts -threaded "-with-rtsopts=-N" - -library - import: extensions - import: ghc-options - exposed-modules: - Graphics.NanoSvg - Graphics.NanoSvg.Color - Graphics.NanoSvg.Internal.Parser - Graphics.NanoSvg.Number - Graphics.NanoSvg.Path - Graphics.NanoSvg.Types - Graphics.NanoSvg.Xml - - hs-source-dirs: lib - - -- Inline the small attribute-parser combinators. - ghc-options: -O2 - build-depends: - base >=4.17 && <4.23, - bytestring >=0.11 && <0.13, - containers >=0.6 && <0.9, - flatparse >=0.5 && <0.6, - hexml >=0.3.5 && <0.4, - primitive >=0.9 && <0.10 - -test-suite nano-svg-test - import: extensions - import: ghc-options - import: rts-options - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - ghc-options: -Wno-missing-export-lists - build-depends: - base, - bytestring, - nano-svg, - primitive, - QuickCheck >=2.14 && <2.19, - tasty >=1.4 && <1.6, - tasty-hunit >=0.10 && <0.11, - tasty-quickcheck >=0.10 && <0.12 +cabal-version: 3.0 +name: nano-svg +version: 0.2.0.0 +synopsis: An SVG parser for icons + +description: + Parse static SVG icons and vector artwork for geometry renderers, + rasterizers and UI toolkits. + + Reads UTF-8 @ByteString@ input using @hexml@ for XML and @flatparse@ + for attribute values. Returns a flat array of shapes in paint order, + each with absolute path segments, a transform and a resolved style. + Rendering and viewport mapping are left to the caller. + + Gradients, patterns, text, masks, clipping paths, filters and CSS + stylesheets are not supported. See "Graphics.NanoSvg" for supported + features and limitations. + +license: MIT +license-file: LICENSE +author: goolord +maintainer: zacharyachurchill@gmail.com +category: Graphics +homepage: https://github.com/goolord/nano-svg +bug-reports: https://github.com/goolord/nano-svg/issues +build-type: Simple +tested-with: GHC ==9.14.1 +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/goolord/nano-svg.git + +common extensions + default-language: GHC2021 + default-extensions: + BlockArguments + LambdaCase + OverloadedStrings + +common ghc-options + ghc-options: + -Wall + -Widentities + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + +common rts-options + ghc-options: -rtsopts -threaded "-with-rtsopts=-N" + +library + import: extensions + import: ghc-options + exposed-modules: + Graphics.NanoSvg + Graphics.NanoSvg.Attribute + Graphics.NanoSvg.Types + + hs-source-dirs: lib + build-depends: + base >=4.17 && <4.23, + bytestring >=0.11.1 && <0.13, + containers >=0.6 && <0.9, + flatparse >=0.5 && <0.6, + hexml >=0.3.5 && <0.4, + primitive >=0.9 && <0.10 + +test-suite nano-svg-test + import: extensions + import: ghc-options + import: rts-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -Wno-missing-export-lists + build-depends: + base, + bytestring, + nano-svg, + primitive, + QuickCheck >=2.14 && <2.19, + tasty >=1.4 && <1.6, + tasty-hunit >=0.10 && <0.11, + tasty-quickcheck >=0.10 && <0.12 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,556 +1,626 @@ --- | Unit tests for SVG parsing and edge cases, plus properties for number --- conversion and relative path commands. -module Main (main) where - -import Data.ByteString (ByteString) -import Data.ByteString.Char8 qualified as BC -import Data.Foldable (toList) -import Graphics.NanoSvg -import Graphics.NanoSvg.Color (namedColor, parseColor, parsePaint) -import Graphics.NanoSvg.Number -import Graphics.NanoSvg.Path (parsePath, parseTransform) -import Graphics.NanoSvg.Xml -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -main :: IO () -main = - defaultMain $ - testGroup - "nano-svg" - [ numbers - , lengths - , colors - , paths - , transforms - , xml - , documents - ] - --------------------------------------------------------------------------------- --- Numbers --------------------------------------------------------------------------------- - -numbers :: TestTree -numbers = - testGroup - "numbers" - [ testCase "the forms the path grammar allows" do - parseNumber "1" @?= Just 1 - parseNumber "-1" @?= Just (-1) - parseNumber "+1" @?= Just 1 - parseNumber "1.5" @?= Just 1.5 - parseNumber ".5" @?= Just 0.5 - parseNumber "-.5" @?= Just (-0.5) - parseNumber "1." @?= Just 1 - parseNumber "1e3" @?= Just 1000 - parseNumber "1E3" @?= Just 1000 - parseNumber "-.5e-3" @?= Just (-0.0005) - parseNumber "1.5e+2" @?= Just 150 - , testCase "and rejects what is not a number" do - parseNumber "" @?= Nothing - parseNumber "." @?= Nothing - parseNumber "-" @?= Nothing - parseNumber "e3" @?= Nothing - parseNumber "1 2" @?= Nothing - parseNumber "abc" @?= Nothing - , testCase "an exponent with no digits is not an exponent" do - -- The @e@ belongs to the unit, so this is one em and not a failure. - parseLength "1em" @?= Just (Length 1 Em) - parseLength "1ex" @?= Just (Length 1 Ex) - , testCase "many digits still land on the right value" do - parseNumber "0.30000000000000004" @?= Just 0.3 - parseNumber "123456789012345678901234" @?= Just 1.2345679e23 - , testCase "a number a Float cannot hold is not a number" do - -- Infinity in a coordinate, or the NaN that @0 * Infinity@ makes, - -- would reach whatever draws the result. - parseNumber "1e400" @?= Nothing - parseNumber "-1e400" @?= Nothing - parseNumber "0e400" @?= Nothing - parseNumber (BC.replicate 400 '9') @?= Nothing - parseNumber "1e-400" @?= Just 0 - parsePath "M1 1L1e400 0" @?= [MoveTo (Point 1 1)] - sizeOf "" @?= (24, 24) - , testCase "lists stop at the first thing that is not a number" do - parseNumberList "1 2 3" @?= [1, 2, 3] - parseNumberList "1,2 , 3" @?= [1, 2, 3] - parseNumberList " 1 2 oops 3" @?= [1, 2] - parseNumberList "" @?= [] - , testCase "a viewBox is four of them" do - parseNumberList "0 0 24 24" @?= [0, 0, 24, 24] - parseNumberList "0 0 24" @?= [0, 0, 24] - parseNumberList "0 0 24 24 24" @?= [0, 0, 24, 24, 24] - , testCase "an odd point is dropped" do - parsePointList "0,0 1,1 2" @?= [Point 0 0, Point 1 1] - , testProperty "agrees with read, to single precision" \(x :: Float) -> - let rendered = BC.pack (show x) - in counterexample (show rendered) $ - maybe False (nearly x) (parseNumber rendered) - , testProperty "reads a list of them" \(xs :: [Float]) -> - let rendered = BC.unwords (map (BC.pack . show) xs) - parsed = parseNumberList rendered - in length parsed == length xs && and (zipWith nearly xs parsed) - ] - --- | Equal to within a single-precision ulp or so, and equal on the --- exceptional values. -nearly :: Float -> Float -> Bool -nearly a b - | isNaN a = isNaN b - | isInfinite a || isInfinite b = a == b - | otherwise = abs (a - b) <= 1e-5 * max 1 (max (abs a) (abs b)) - --------------------------------------------------------------------------------- --- Lengths --------------------------------------------------------------------------------- - -lengths :: TestTree -lengths = - testGroup - "lengths" - [ testCase "units are read" do - parseLength "10" @?= Just (Length 10 UserSpace) - parseLength "10px" @?= Just (Length 10 Px) - parseLength "10PX" @?= Just (Length 10 Px) - parseLength "10pt" @?= Just (Length 10 Pt) - parseLength "10%" @?= Just (Length 10 Percent) - parseLength "10 " @?= Just (Length 10 UserSpace) - parseLength "10 px" @?= Nothing - , testCase "the absolute ones resolve at 96 dpi" do - parseUserUnits "10" @?= Just 10 - parseUserUnits "10px" @?= Just 10 - parseUserUnits "1in" @?= Just 96 - parseUserUnits "72pt" @?= Just 96 - parseUserUnits "6pc" @?= Just 96 - fmap (round :: Float -> Int) (parseUserUnits "2.54cm") @?= Just 96 - fmap (round :: Float -> Int) (parseUserUnits "25.4mm") @?= Just 96 - , testCase "and the relative ones do not" do - parseUserUnits "50%" @?= Nothing - parseUserUnits "2em" @?= Nothing - parseUserUnits "2ex" @?= Nothing - ] - --------------------------------------------------------------------------------- --- Colors --------------------------------------------------------------------------------- - -colors :: TestTree -colors = - testGroup - "colors" - [ testCase "hexadecimal, short and long" do - parseColor "#f00" @?= Just (rgba 255 0 0 255) - parseColor "#FF0000" @?= Just (rgba 255 0 0 255) - parseColor "#f008" @?= Just (rgba 255 0 0 0x88) - parseColor "#ff000080" @?= Just (rgba 255 0 0 0x80) - parseColor "#ff00" @?= Just (rgba 255 255 0 0) - parseColor "#fffff" @?= Nothing - , testCase "rgb, however it is written" do - parseColor "rgb(255,0,0)" @?= Just (rgba 255 0 0 255) - parseColor "rgb(255 0 0)" @?= Just (rgba 255 0 0 255) - parseColor "rgb( 100%, 0%, 0% )" @?= Just (rgba 255 0 0 255) - parseColor "rgba(255,0,0,0.5)" @?= Just (rgba 255 0 0 128) - parseColor "rgb(255 0 0 / 50%)" @?= Just (rgba 255 0 0 128) - parseColor "rgb(300,-20,0)" @?= Just (rgba 255 0 0 255) - , testCase "hsl" do - parseColor "hsl(0,100%,50%)" @?= Just (rgba 255 0 0 255) - parseColor "hsl(120, 100%, 50%)" @?= Just (rgba 0 255 0 255) - parseColor "hsl(240deg 100% 50%)" @?= Just (rgba 0 0 255 255) - parseColor "hsl(0, 0%, 100%)" @?= Just (rgba 255 255 255 255) - parseColor "hsla(0,100%,50%,0.5)" @?= Just (rgba 255 0 0 128) - , testCase "all 148 keywords, in any case" do - parseColor "red" @?= Just (rgba 255 0 0 255) - parseColor "REBECCAPURPLE" @?= Just (rgba 0x66 0x33 0x99 255) - parseColor "rebeccapurple" @?= namedColor "rebeccapurple" - parseColor "lightgoldenrodyellow" @?= Just (rgba 0xfa 0xfa 0xd2 255) - parseColor "grey" @?= parseColor "gray" - parseColor "notacolor" @?= Nothing - , testCase "paint keywords are not colors" do - parsePaint "none" @?= Just PaintNone - parsePaint "transparent" @?= Just PaintNone - parsePaint "currentColor" @?= Just PaintCurrent - parsePaint " currentcolor " @?= Just PaintCurrent - parsePaint "red" @?= Just (PaintColor (rgba 255 0 0 255)) - parsePaint "rgb(0,0,0)" @?= Just (PaintColor (rgba 0 0 0 255)) - , testCase "and what cannot be read is not a paint" do - parsePaint "url(#grad)" @?= Nothing - parsePaint "inherit" @?= Nothing - parsePaint "" @?= Nothing - ] - --------------------------------------------------------------------------------- --- Paths --------------------------------------------------------------------------------- - -paths :: TestTree -paths = - testGroup - "path data" - [ testCase "absolute commands" $ - parsePath "M1 2 L3 4 H5 V6 Z" - @?= [ MoveTo (Point 1 2) - , LineTo (Point 3 4) - , LineTo (Point 5 4) - , LineTo (Point 5 6) - , ClosePath - ] - , testCase "relative commands are resolved" $ - parsePath "m1 2 l1 1 h1 v1 z" - @?= [ MoveTo (Point 1 2) - , LineTo (Point 2 3) - , LineTo (Point 3 3) - , LineTo (Point 3 4) - , ClosePath - ] - , testCase "a run of arguments repeats the command" $ - parsePath "M1 1 2 2 3 3" - @?= [MoveTo (Point 1 1), LineTo (Point 2 2), LineTo (Point 3 3)] - , testCase "and a relative moveto repeats as a relative lineto" $ - parsePath "m1 1 1 1 1 1" - @?= [MoveTo (Point 1 1), LineTo (Point 2 2), LineTo (Point 3 3)] - , testCase "after a closepath the current point is the subpath start" do - -- An explicit command after the Z draws from where the subpath - -- began, not from where it ended. - parsePath "M2 2 L4 4 Z l1 1" - @?= [ MoveTo (Point 2 2) - , LineTo (Point 4 4) - , ClosePath - , LineTo (Point 3 3) - ] - -- A bare pair after it opens a new subpath there instead. - parsePath "M2 2 L4 4 Z 1 1" - @?= [ MoveTo (Point 2 2) - , LineTo (Point 4 4) - , ClosePath - , MoveTo (Point 1 1) - ] - , testCase "S reflects a cubic control point" $ - parsePath "M0 0 C1 1 2 2 3 3 S5 5 6 6" - @?= [ CubicTo (Point 1 1) (Point 2 2) (Point 3 3) - , CubicTo (Point 4 4) (Point 5 5) (Point 6 6) - ] - `prefixedByMove` Point 0 0 - , testCase "but not a quadratic one" $ - -- The previous command is a Q, so the S has nothing to reflect and - -- its first control point is the current point. - parsePath "M0 0 Q1 1 2 2 S5 5 6 6" - @?= [ QuadTo (Point 1 1) (Point 2 2) - , CubicTo (Point 2 2) (Point 5 5) (Point 6 6) - ] - `prefixedByMove` Point 0 0 - , testCase "T reflects a quadratic control point" $ - parsePath "M0 0 Q1 1 2 2 T4 4" - @?= [QuadTo (Point 1 1) (Point 2 2), QuadTo (Point 3 3) (Point 4 4)] - `prefixedByMove` Point 0 0 - , testCase "arc flags need no separator" $ - parsePath "M2 10a8 8 0 1 1 16 0z" - @?= parsePath "M2 10a8 8 0 1116 0z" - , testCase "and run into the numbers after them" $ - parsePath "M0 0a1 1 0 00.5.5" - @?= [MoveTo (Point 0 0), ArcTo 1 1 0 False False (Point 0.5 0.5)] - , testCase "a malformed tail keeps what came before it" do - parsePath "M1 1 L2 2 L3" @?= [MoveTo (Point 1 1), LineTo (Point 2 2)] - parsePath "M1 1 L2 2 X9 9" @?= [MoveTo (Point 1 1), LineTo (Point 2 2)] - parsePath "" @?= [] - parsePath "nonsense" @?= [] - , testCase "commas and exponents in a d" $ - parsePath "M1e1,1e1L2e1,2e1" - @?= [MoveTo (Point 10 10), LineTo (Point 20 20)] - , testProperty "a relative path draws where the absolute one does" \ps -> - let steps = take 12 (map (\(Small a, Small b) -> (a, b)) ps) :: [(Int, Int)] - absolute = scanl1 (\(x, y) (dx, dy) -> (x + dx, y + dy)) steps - render c = BC.unwords [BC.pack (show a <> " " <> show b) | (a, b) <- c] - in not (null steps) ==> - parsePath ("M0 0 l" <> render steps) - == parsePath ("M0 0 L" <> render absolute) - ] - --- | A path's segments after the moveto that opened it. -prefixedByMove :: [Segment] -> Point -> [Segment] -prefixedByMove segs p = MoveTo p : segs - --------------------------------------------------------------------------------- --- Transforms --------------------------------------------------------------------------------- - -transforms :: TestTree -transforms = - testGroup - "transforms" - [ testCase "each function" do - parseTransform "matrix(1 2 3 4 5 6)" @?= Matrix 1 2 3 4 5 6 - parseTransform "translate(5)" @?= Matrix 1 0 0 1 5 0 - parseTransform "translate(5, 6)" @?= Matrix 1 0 0 1 5 6 - parseTransform "scale(2)" @?= Matrix 2 0 0 2 0 0 - parseTransform "scale(2,3)" @?= Matrix 2 0 0 3 0 0 - parseTransform "" @?= identity - parseTransform "nonsense" @?= identity - , testCase "a rotation about a point leaves that point alone" $ - let m = parseTransform "rotate(90 10 10)" - Point x y = transformPoint m (Point 10 10) - in (round x, round y) @?= (10 :: Int, 10 :: Int) - , testCase "a list composes left to right" $ - let m = parseTransform "translate(10 0) scale(2)" - in transformPoint m (Point 1 1) @?= Point 12 2 - , testCase "and the outer one is applied last" $ - let m = parseTransform "scale(2) translate(10 0)" - in transformPoint m (Point 1 1) @?= Point 22 2 - , testCase "a scale shows up in the length factor" do - averageScale (parseTransform "scale(3)") @?= 3 - averageScale (parseTransform "translate(9 9)") @?= 1 - ] - --------------------------------------------------------------------------------- --- XML --------------------------------------------------------------------------------- - -xml :: TestTree -xml = - testGroup - "xml" - [ testCase "elements and attributes" $ - parseXml "" - @?= Right [Element "a" [Attribute "x" "1"] [Element "b" [] []]] - , testCase "namespace prefixes are dropped" $ - fmap (map elementName) (parseXml "") - @?= Right ["svg"] - , testCase "comments and instructions are not in the tree" $ - fmap (map elementName) (parseXml "") - @?= Right ["a"] - , testCase "a doctype is stepped over" $ - fmap (map elementName) (parseXml "") - @?= Right ["svg"] - , testCase "including one with an internal subset" $ - fmap (map elementName) (parseXml "]>") - @?= Right ["svg"] - , testCase "and so is a byte-order mark" $ - fmap (map elementName) (parseXml "\xEF\xBB\xBF") - @?= Right ["svg"] - , testCase "entities in attribute values" do - decodeEntities "a&b" @?= "a&b" - decodeEntities "<>"'" @?= "<>\"'" - decodeEntities "ABC" @?= "ABC" - decodeEntities "✓" @?= "\xE2\x9C\x93" - decodeEntities "plain" @?= "plain" - decodeEntities "50% & more" @?= "50% & more" - , testCase "an ampersand that begins nothing stands for itself" do - decodeEntities "a & b" @?= "a & b" - decodeEntities "&nosuch;" @?= "&nosuch;" - decodeEntities "&#;" @?= "&#;" - , testCase "attributes are looked up by local name" do - let el = Element "use" [Attribute "href" "#a"] [] - attribute "href" el @?= Just "#a" - attribute "x" el @?= Nothing - , testCase "a document that is not one" $ - assertBool "expected a Left" (isLeft (parseXml "")) - ] - -isLeft :: Either a b -> Bool -isLeft = either (const True) (const False) - --------------------------------------------------------------------------------- --- Documents --------------------------------------------------------------------------------- - -documents :: TestTree -documents = - testGroup - "documents" - [ testCase "a document needs an svg element" do - assertBool "expected a Left" (isLeft (parseSvg "")) - assertBool "expected a Left" (isLeft (parseSvg "not xml at all")) - , testCase "the size and the box" do - sizeOf "" @?= (48, 32) - sizeOf "" @?= (24, 24) - sizeOf "" @?= (48, 48) - sizeOf "" @?= (96, 96) - -- A percentage is not a length, so the viewBox decides. - sizeOf "" @?= (16, 16) - sizeOf "" @?= (24, 24) - boxOf "" @?= Box 1 2 24 25 - -- A viewBox that is not four numbers, or has no extent, is not one. - boxOf "" @?= Box 0 0 8 9 - boxOf "" @?= Box 0 0 8 9 - boxOf "" @?= Box 0 0 8 9 - , testCase "shapes come out in paint order" $ - map (length . toList . shapeSegments) (shapesOf clock) @?= [4, 3] - , testCase "an icon drawn in currentColor is monochrome" do - fmap documentMonochrome (parseSvg clock) @?= Right True - fmap documentMonochrome (parseSvg holed) @?= Right False - fmap documentMonochrome (parseSvg "") - @?= Right True - , testCase "presentation attributes are inherited" $ - let sh = - oneShape "" - in do - styleStrokeWidth (shapeStyle sh) @?= 3 - styleStroke (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255)) - , testCase "a style attribute outranks them" $ - let sh = oneShape "" - in styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 0 0 255 255)) - , testCase "a value that cannot be read leaves the inherited one" $ - let sh = oneShape "" - in styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255)) - , testCase "an opacity may be a percentage" do - styleOpacity (shapeStyle (oneShape "")) - @?= 0.5 - styleFillOpacity - (shapeStyle (oneShape "")) - @?= 0.25 - , testCase "opacity multiplies down the tree" $ - let sh = oneShape "" - in styleOpacity (shapeStyle sh) @?= 0.25 - , testCase "and a style attribute outranks a presentation one there too" $ - styleOpacity - ( shapeStyle - (oneShape "") - ) - @?= 0.25 - , testCase "a switch draws the first child that draws anything" do - map (length . toList . shapeSegments) (shapesOf switchDoc) @?= [2] - shapesOf "nothing here" @?= [] - , testCase "transforms compose down it" $ - let sh = - oneShape - "" - in transformPoint (shapeTransform sh) (Point 1 1) @?= Point 7 2 - , testCase "the shape elements each become segments" do - map (length . toList . shapeSegments) (shapesOf rectangles) @?= [5, 10] - map - (length . toList . shapeSegments) - (shapesOf "") - @?= [4, 4] - map - (length . toList . shapeSegments) - (shapesOf "") - @?= [2] - -- A polyline is not closed, so two points are two segments; the - -- polygon's three are a moveto, two linetos and a closepath. - map (length . toList . shapeSegments) (shapesOf polys) @?= [2, 4] - , testCase "a shape with no extent draws nothing" do - shapesOf "" @?= [] - shapesOf "" @?= [] - shapesOf "" @?= [] - , testCase "defs are not drawn where they stand" $ - shapesOf "" @?= [] - , testCase "but a use draws them, offset and styled" $ - let sh = oneShape useDoc - in do - transformPoint (shapeTransform sh) (Point 0 0) @?= Point 5 6 - styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255)) - , testCase "a use of a symbol draws its children" $ - length (shapesOf symbolDoc) @?= 2 - , testCase "the same target may be used more than once" $ - length (shapesOf twiceDoc) @?= 2 - , testCase "and a circular one draws each target once" do - -- A cycle is cut where it closes, so a group that references - -- itself several times cannot fan out: counting depth alone would - -- let four self-references become tens of thousands of shapes. - length (shapesOf (circularFanout 1)) @?= 1 - length (shapesOf (circularFanout 4)) @?= 1 - length (shapesOf (circularFanout 12)) @?= 1 - , testCase "and a self-referential one terminates" $ - length (shapesOf circular) <= 8 @?= True - , testCase "display and visibility prune the subtree" do - shapesOf "" @?= [] - shapesOf "" @?= [] - shapesOf "" - @?= [] - length - (shapesOf "") - @?= 1 - , testCase "and a style declaration outranks the attribute there too" do - length - ( shapesOf - "" - ) - @?= 1 - shapesOf - "" - @?= [] - , testCase "text, gradients and the rest are skipped" $ - shapesOf - "hi" - @?= [] - , testCase "the key follows the source" do - fmap documentKey (parseSvg clock) @?= fmap documentKey (parseSvg clock) - assertBool "different sources, different keys" $ - fmap documentKey (parseSvg clock) /= fmap documentKey (parseSvg holed) - , testCase "and two documents are equal when their sources are" do - parseSvg clock @?= parseSvg clock - assertBool "different sources, different documents" $ - parseSvg clock /= parseSvg holed - ] - --------------------------------------------------------------------------------- --- Fixtures --------------------------------------------------------------------------------- - --- | A Lucide-style icon: the shape the overwhelming majority of icon sets --- take, down to the comment in the middle. -clock :: ByteString -clock = - "\ - \" - -holed :: ByteString -holed = - "\ - \" - -rectangles :: ByteString -rectangles = - "" - -polys :: ByteString -polys = - "" - -useDoc :: ByteString -useDoc = - "\ - \" - -symbolDoc :: ByteString -symbolDoc = - "\ - \" - -twiceDoc :: ByteString -twiceDoc = - "\ - \" - --- | A group that refers to itself @n@ times and also draws one rectangle. -circularFanout :: Int -> ByteString -circularFanout n = - "" - <> mconcat (replicate n "") - <> "" - -circular :: ByteString -circular = - "\ - \" - -switchDoc :: ByteString -switchDoc = - "a description is not a drawing\ - \" - -sizeOf :: ByteString -> (Float, Float) -sizeOf = either (error "parse failed") documentSize . parseSvg - -boxOf :: ByteString -> Box -boxOf = either (error "parse failed") documentViewBox . parseSvg - -shapesOf :: ByteString -> [Shape] -shapesOf = either (error "parse failed") (toList . documentShapes) . parseSvg - --- | The one shape a document was meant to have. -oneShape :: ByteString -> Shape -oneShape src = case shapesOf src of - [sh] -> sh - shs -> error ("expected one shape, got " <> show (length shs)) +-- | Unit tests for SVG parsing and edge cases, plus properties for number +-- conversion and relative path commands. +module Main (main) where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Builder qualified as B +import Data.ByteString.Char8 qualified as BC +import Data.Foldable (for_, toList) +import Data.Primitive.SmallArray (smallArrayFromList) +import Graphics.NanoSvg +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck hiding (NonZero) + +main :: IO () +main = + defaultMain $ + testGroup + "nano-svg" + [ numbers + , lengths + , colors + , paths + , transforms + , xml + , documents + , encoding + ] + +-------------------------------------------------------------------------------- +-- Numbers +-------------------------------------------------------------------------------- + +numbers :: TestTree +numbers = + testGroup + "numbers" + [ testCase "the forms the path grammar allows" do + parseNumber "1" @?= Just 1 + parseNumber "-1" @?= Just (-1) + parseNumber "+1" @?= Just 1 + parseNumber "1.5" @?= Just 1.5 + parseNumber ".5" @?= Just 0.5 + parseNumber "-.5" @?= Just (-0.5) + parseNumber "1." @?= Just 1 + parseNumber "1e3" @?= Just 1000 + parseNumber "1E3" @?= Just 1000 + parseNumber "-.5e-3" @?= Just (-0.0005) + parseNumber "1.5e+2" @?= Just 150 + , testCase "and rejects what is not a number" do + parseNumber "" @?= Nothing + parseNumber "." @?= Nothing + parseNumber "-" @?= Nothing + parseNumber "e3" @?= Nothing + parseNumber "1 2" @?= Nothing + parseNumber "abc" @?= Nothing + , testCase "an exponent with no digits is not an exponent" do + -- The @e@ belongs to the unit, so this is one em and not a failure. + parseLength "1e1px" @?= Just 10 + styleStrokeWidth (shapeStyle (oneShape "")) @?= 1 + , testCase "many digits still land on the right value" do + parseNumber "0.30000000000000004" @?= Just 0.3 + parseNumber "123456789012345678901234" @?= Just 1.2345679e23 + , testCase "a number a Float cannot hold is not a number" do + -- Infinity in a coordinate, or the NaN that @0 * Infinity@ makes, + -- would reach whatever draws the result. + parseNumber "1e400" @?= Nothing + parseNumber "-1e400" @?= Nothing + parseNumber (BC.replicate 400 '9') @?= Nothing + parseNumber "1e-400" @?= Just 0 + , testCase "but a large exponent on a small mantissa, or the reverse, is" do + parseNumber "0e400" @?= Just 0 + parseNumber "-0.000e9999" @?= Just 0 + parseNumber ("1" <> BC.replicate 400 '0' <> "e-400") @?= Just 1 + parseNumber ("0." <> BC.replicate 400 '0' <> "15e401") @?= Just 1.5 + parsePath "M1 1L1e400 0" @?= [MoveTo (Point 1 1)] + sizeOf "" @?= (24, 24) + , testCase "an odd point is dropped" $ + map (toList . shapeSegments) (shapesOf "") + @?= [[MoveTo (Point 0 0), LineTo (Point 1 1)]] + , testProperty "agrees with read, to single precision" \(x :: Float) -> + let rendered = BC.pack (show x) + in counterexample (show rendered) $ + maybe False (nearly x) (parseNumber rendered) + ] + +-- | Equal to within a single-precision ulp or so, and equal on the +-- exceptional values. +nearly :: Float -> Float -> Bool +nearly a b + | isNaN a = isNaN b + | isInfinite a || isInfinite b = a == b + | otherwise = abs (a - b) <= 1e-5 * max 1 (max (abs a) (abs b)) + +-------------------------------------------------------------------------------- +-- Lengths +-------------------------------------------------------------------------------- + +lengths :: TestTree +lengths = + testGroup + "lengths" + [ testCase "the absolute ones resolve at 96 dpi" do + parseLength "10" @?= Just 10 + parseLength "10px" @?= Just 10 + parseLength "10PX" @?= Just 10 + parseLength "10 " @?= Just 10 + parseLength "10 px" @?= Nothing + parseLength "1in" @?= Just 96 + parseLength "72pt" @?= Just 96 + parseLength "6pc" @?= Just 96 + fmap (round :: Float -> Int) (parseLength "2.54cm") @?= Just 96 + fmap (round :: Float -> Int) (parseLength "25.4mm") @?= Just 96 + , testCase "and the relative ones do not" do + parseLength "50%" @?= Nothing + parseLength "2em" @?= Nothing + parseLength "2ex" @?= Nothing + parseLength "2foo" @?= Nothing + ] + +-------------------------------------------------------------------------------- +-- Colors +-------------------------------------------------------------------------------- + +colors :: TestTree +colors = + testGroup + "colors" + [ testCase "hexadecimal, short and long" do + parseColor "#f00" @?= Just (rgba 255 0 0 255) + parseColor "#FF0000" @?= Just (rgba 255 0 0 255) + parseColor "#f008" @?= Just (rgba 255 0 0 0x88) + parseColor "#ff000080" @?= Just (rgba 255 0 0 0x80) + parseColor "#ff00" @?= Just (rgba 255 255 0 0) + parseColor "#fffff" @?= Nothing + , testCase "rgb, however it is written" do + parseColor "rgb(255,0,0)" @?= Just (rgba 255 0 0 255) + parseColor "rgb(255 0 0)" @?= Just (rgba 255 0 0 255) + parseColor "rgb( 100%, 0%, 0% )" @?= Just (rgba 255 0 0 255) + parseColor "rgba(255,0,0,0.5)" @?= Just (rgba 255 0 0 128) + parseColor "rgb(255 0 0 / 50%)" @?= Just (rgba 255 0 0 128) + parseColor "rgb(300,-20,0)" @?= Just (rgba 255 0 0 255) + , testCase "hsl" do + parseColor "hsl(0,100%,50%)" @?= Just (rgba 255 0 0 255) + parseColor "hsl(120, 100%, 50%)" @?= Just (rgba 0 255 0 255) + parseColor "hsl(240deg 100% 50%)" @?= Just (rgba 0 0 255 255) + parseColor "hsl(0, 0%, 100%)" @?= Just (rgba 255 255 255 255) + parseColor "hsla(0,100%,50%,0.5)" @?= Just (rgba 255 0 0 128) + , testCase "all 148 keywords, in any case" do + parseColor "red" @?= Just (rgba 255 0 0 255) + parseColor "REBECCAPURPLE" @?= Just (rgba 0x66 0x33 0x99 255) + parseColor "aliceblue" @?= Just (rgba 0xf0 0xf8 0xff 255) + parseColor "yellowgreen" @?= Just (rgba 0x9a 0xcd 0x32 255) + parseColor "lightgoldenrodyellow" @?= Just (rgba 0xfa 0xfa 0xd2 255) + parseColor "grey" @?= parseColor "gray" + parseColor "notacolor" @?= Nothing + parseColor "transparent" @?= Nothing + show (rgba 1 2 3 255) @?= "#010203ff" + , testCase "paint keywords are not colors" do + parsePaint "none" @?= Just PaintNone + parsePaint "transparent" @?= Just PaintNone + parsePaint "currentColor" @?= Just PaintCurrent + parsePaint " currentcolor " @?= Just PaintCurrent + parsePaint "red" @?= Just (PaintColor (rgba 255 0 0 255)) + parsePaint "rgb(0,0,0)" @?= Just (PaintColor (rgba 0 0 0 255)) + , testCase "and what cannot be read is not a paint" do + parsePaint "url(#grad)" @?= Nothing + parsePaint "inherit" @?= Nothing + parsePaint "" @?= Nothing + ] + +-------------------------------------------------------------------------------- +-- Paths +-------------------------------------------------------------------------------- + +paths :: TestTree +paths = + testGroup + "path data" + [ testCase "absolute commands" $ + parsePath "M1 2 L3 4 H5 V6 Z" + @?= [ MoveTo (Point 1 2) + , LineTo (Point 3 4) + , LineTo (Point 5 4) + , LineTo (Point 5 6) + , ClosePath + ] + , testCase "relative commands are resolved" $ + parsePath "m1 2 l1 1 h1 v1 z" + @?= [ MoveTo (Point 1 2) + , LineTo (Point 2 3) + , LineTo (Point 3 3) + , LineTo (Point 3 4) + , ClosePath + ] + , testCase "a run of arguments repeats the command" $ + parsePath "M1 1 2 2 3 3" + @?= [MoveTo (Point 1 1), LineTo (Point 2 2), LineTo (Point 3 3)] + , testCase "and a relative moveto repeats as a relative lineto" $ + parsePath "m1 1 1 1 1 1" + @?= [MoveTo (Point 1 1), LineTo (Point 2 2), LineTo (Point 3 3)] + , testCase "after a closepath the current point is the subpath start" do + -- An explicit command after the Z draws from where the subpath + -- began, not from where it ended. + parsePath "M2 2 L4 4 Z l1 1" + @?= [ MoveTo (Point 2 2) + , LineTo (Point 4 4) + , ClosePath + , LineTo (Point 3 3) + ] + -- A bare pair after it opens a new subpath there instead. + parsePath "M2 2 L4 4 Z 1 1" + @?= [ MoveTo (Point 2 2) + , LineTo (Point 4 4) + , ClosePath + , MoveTo (Point 1 1) + ] + , testCase "S reflects a cubic control point" $ + parsePath "M0 0 C1 1 2 2 3 3 S5 5 6 6" + @?= [ CubicTo (Point 1 1) (Point 2 2) (Point 3 3) + , CubicTo (Point 4 4) (Point 5 5) (Point 6 6) + ] + `prefixedByMove` Point 0 0 + , testCase "but not a quadratic one" $ + -- The previous command is a Q, so the S has nothing to reflect and + -- its first control point is the current point. + parsePath "M0 0 Q1 1 2 2 S5 5 6 6" + @?= [ QuadTo (Point 1 1) (Point 2 2) + , CubicTo (Point 2 2) (Point 5 5) (Point 6 6) + ] + `prefixedByMove` Point 0 0 + , testCase "T reflects a quadratic control point" $ + parsePath "M0 0 Q1 1 2 2 T4 4" + @?= [QuadTo (Point 1 1) (Point 2 2), QuadTo (Point 3 3) (Point 4 4)] + `prefixedByMove` Point 0 0 + , testCase "arc flags need no separator" $ + parsePath "M2 10a8 8 0 1 1 16 0z" + @?= parsePath "M2 10a8 8 0 1116 0z" + , testCase "and run into the numbers after them" $ + parsePath "M0 0a1 1 0 00.5.5" + @?= [MoveTo (Point 0 0), ArcTo 1 1 0 False False (Point 0.5 0.5)] + , testCase "a malformed tail keeps what came before it" do + parsePath "M1 1 L2 2 L3" @?= [MoveTo (Point 1 1), LineTo (Point 2 2)] + parsePath "M1 1 L2 2 X9 9" @?= [MoveTo (Point 1 1), LineTo (Point 2 2)] + parsePath "" @?= [] + parsePath "nonsense" @?= [] + , testCase "commas and exponents in a d" $ + parsePath "M1e1,1e1L2e1,2e1" + @?= [MoveTo (Point 10 10), LineTo (Point 20 20)] + , testProperty "a relative path draws where the absolute one does" \ps -> + let steps = take 12 (map (\(Small a, Small b) -> (a, b)) ps) :: [(Int, Int)] + absolute = scanl1 (\(x, y) (dx, dy) -> (x + dx, y + dy)) steps + render c = foldMap (\(a, b) -> " " <> B.intDec a <> " " <> B.intDec b) c + in not (null steps) ==> + parsePath (build ("M0 0 l" <> render steps)) + == parsePath (build ("M0 0 L" <> render absolute)) + ] + +-- | A path's segments after the moveto that opened it. +prefixedByMove :: [Segment] -> Point -> [Segment] +prefixedByMove segs p = MoveTo p : segs + +-------------------------------------------------------------------------------- +-- Transforms +-------------------------------------------------------------------------------- + +transforms :: TestTree +transforms = + testGroup + "transforms" + [ testCase "each function" do + parseTransform "matrix(1 2 3 4 5 6)" @?= Matrix 1 2 3 4 5 6 + parseTransform "translate(5)" @?= Matrix 1 0 0 1 5 0 + parseTransform "translate(5, 6)" @?= Matrix 1 0 0 1 5 6 + parseTransform "scale(2)" @?= Matrix 2 0 0 2 0 0 + parseTransform "scale(2,3)" @?= Matrix 2 0 0 3 0 0 + parseTransform "" @?= identity + parseTransform "nonsense" @?= identity + , testCase "a rotation about a point leaves that point alone" $ + let m = parseTransform "rotate(90 10 10)" + Point x y = transformPoint m (Point 10 10) + in (round x, round y) @?= (10 :: Int, 10 :: Int) + , testCase "a list composes left to right" $ + let m = parseTransform "translate(10 0) scale(2)" + in transformPoint m (Point 1 1) @?= Point 12 2 + , testCase "and the outer one is applied last" $ + let m = parseTransform "scale(2) translate(10 0)" + in transformPoint m (Point 1 1) @?= Point 22 2 + , testCase "a scale shows up in the length factor" do + averageScale (parseTransform "scale(3)") @?= 3 + averageScale (parseTransform "translate(9 9)") @?= 1 + ] + +-------------------------------------------------------------------------------- +-- XML +-------------------------------------------------------------------------------- + +xml :: TestTree +xml = + testGroup + "xml" + [ testCase "namespace prefixes are dropped" do + length (shapesOf "") @?= 1 + length (shapesOf useDoc) @?= 1 + , testCase "comments, instructions, doctypes and byte-order marks are skipped" do + sizeOf "" @?= (3, 24) + sizeOf "" @?= (3, 24) + sizeOf "]>" @?= (3, 24) + sizeOf "" @?= (3, 24) + , testCase "entities in attribute values" do + styleFill (shapeStyle (oneShape "")) + @?= Just (PaintColor (rgba 255 0 0 255)) + map (length . toList . shapeSegments) (shapesOf "") @?= [2] + , testCase "an ampersand that begins nothing stands for itself" $ + map (length . toList . shapeSegments) (shapesOf "") + @?= [1] + , testCase "and so does a reference past the last code point" $ + -- Would wrap around to 'r' in 64-bit arithmetic. + styleFill (shapeStyle (oneShape "")) + @?= Nothing + , testCase "a document that is not one" $ + assertBool "expected a Left" (isLeft (parseSvg "")) + ] + +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False) + +-------------------------------------------------------------------------------- +-- Documents +-------------------------------------------------------------------------------- + +documents :: TestTree +documents = + testGroup + "documents" + [ testCase "a document needs an svg element" do + assertBool "expected a Left" (isLeft (parseSvg "")) + assertBool "expected a Left" (isLeft (parseSvg "not xml at all")) + , testCase "the size and the box" do + sizeOf "" @?= (48, 32) + sizeOf "" @?= (24, 24) + sizeOf "" @?= (48, 48) + sizeOf "" @?= (96, 96) + -- A percentage is not a length, so the viewBox decides. + sizeOf "" @?= (16, 16) + sizeOf "" @?= (24, 24) + boxOf "" @?= Box 1 2 24 25 + -- A viewBox that is not four numbers, or has no extent, is not one. + boxOf "" @?= Box 0 0 8 9 + boxOf "" @?= Box 0 0 8 9 + boxOf "" @?= Box 0 0 8 9 + , testCase "shapes come out in paint order" $ + map (length . toList . shapeSegments) (shapesOf clock) @?= [4, 3] + , testCase "an icon drawn in currentColor is monochrome" do + fmap documentMonochrome (parseSvg clock) @?= Right True + fmap documentMonochrome (parseSvg holed) @?= Right False + fmap documentMonochrome (parseSvg "") + @?= Right True + , testCase "presentation attributes are inherited" $ + let sh = + oneShape "" + in do + styleStrokeWidth (shapeStyle sh) @?= 3 + styleStroke (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255)) + , testCase "a style attribute outranks them" $ + let sh = oneShape "" + in styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 0 0 255 255)) + , testCase "a value that cannot be read leaves the inherited one" $ + let sh = oneShape "" + in styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255)) + , testCase "an opacity may be a percentage" do + styleOpacity (shapeStyle (oneShape "")) + @?= 0.5 + styleFillOpacity + (shapeStyle (oneShape "")) + @?= 0.25 + , testCase "opacity multiplies down the tree" $ + let sh = oneShape "" + in styleOpacity (shapeStyle sh) @?= 0.25 + , testCase "and a style attribute outranks a presentation one there too" $ + styleOpacity + ( shapeStyle + (oneShape "") + ) + @?= 0.25 + , testCase "a switch draws the first child that draws anything" do + map (length . toList . shapeSegments) (shapesOf switchDoc) @?= [2] + shapesOf "nothing here" @?= [] + , testCase "transforms compose down it" $ + let sh = + oneShape + "" + in transformPoint (shapeTransform sh) (Point 1 1) @?= Point 7 2 + , testCase "the shape elements each become segments" do + map (length . toList . shapeSegments) (shapesOf rectangles) @?= [5, 10] + map + (length . toList . shapeSegments) + (shapesOf "") + @?= [4, 4] + map + (length . toList . shapeSegments) + (shapesOf "") + @?= [2] + -- A polyline is not closed, so two points are two segments; the + -- polygon's three are a moveto, two linetos and a closepath. + map (length . toList . shapeSegments) (shapesOf polys) @?= [2, 4] + , testCase "a shape with no extent draws nothing" do + shapesOf "" @?= [] + shapesOf "" @?= [] + shapesOf "" @?= [] + , testCase "defs are not drawn where they stand" $ + shapesOf "" @?= [] + , testCase "but a use draws them, offset and styled" $ + let sh = oneShape useDoc + in do + transformPoint (shapeTransform sh) (Point 0 0) @?= Point 5 6 + styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255)) + , testCase "a use of a symbol draws its children" $ + length (shapesOf symbolDoc) @?= 2 + , testCase "the same target may be used more than once" $ + length (shapesOf twiceDoc) @?= 2 + , testCase "a duplicated id refers to its first element" $ + map (length . toList . shapeSegments) + (shapesOf "") + @?= [2] + , testCase "and a circular one draws each target once" do + -- A cycle is cut where it closes, so a group that references + -- itself several times cannot fan out: counting depth alone would + -- let four self-references become tens of thousands of shapes. + length (shapesOf (circularFanout 1)) @?= 1 + length (shapesOf (circularFanout 4)) @?= 1 + length (shapesOf (circularFanout 12)) @?= 1 + , testCase "and a self-referential one terminates" $ + length (shapesOf circular) <= 8 @?= True + , testCase "uses nest up to the limit and no deeper" do + length (shapesOf (useChain maxUseDepth)) @?= 1 + length (shapesOf (useChain (maxUseDepth + 1))) @?= 0 + , testCase "so a use that fans out cannot explode" do + length (shapesOf (fanout (maxUseDepth - 1))) @?= 2 ^ (maxUseDepth - 1) + length (shapesOf (fanout 40)) @?= 0 + , testCase "display and visibility prune the subtree" do + shapesOf "" @?= [] + shapesOf "" @?= [] + shapesOf "" + @?= [] + length + (shapesOf "") + @?= 1 + , testCase "and a style declaration outranks the attribute there too" do + length + ( shapesOf + "" + ) + @?= 1 + shapesOf + "" + @?= [] + , testCase "text, gradients and the rest are skipped" $ + shapesOf + "hi" + @?= [] + , testCase "the key follows the source" do + fmap documentKey (parseSvg clock) @?= fmap documentKey (parseSvg clock) + assertBool "different sources, different keys" $ + fmap documentKey (parseSvg clock) /= fmap documentKey (parseSvg holed) + , testCase "and two documents are equal when their sources are" do + parseSvg clock @?= parseSvg clock + assertBool "different sources, different documents" $ + parseSvg clock /= parseSvg holed + ] + +-------------------------------------------------------------------------------- +-- Encoding +-------------------------------------------------------------------------------- + +encoding :: TestTree +encoding = + testGroup + "encoding" + [ testCase "a path per shape, with what differs from the defaults" $ + either error encodeSvg (parseSvg holed) + @?= "\ + \\ + \" + , testCase "a translucent color keeps its alpha, and a fraction its digits" $ + either error encodeSvg (parseSvg "") + @?= "\ + \" + , testCase "the fixtures read back as they were" $ + for_ [clock, holed, rectangles, polys, useDoc, twiceDoc, switchDoc] \src -> + let doc = either error id (parseSvg src) + in fmap (\d -> (documentViewBox d, documentSize d, toList (documentShapes d))) (parseSvg (encodeSvg doc)) + @?= Right (documentViewBox doc, documentSize doc, toList (documentShapes doc)) + , testProperty "any shapes read back as they were" $ + forAll (listOf1 genShape) \shs -> + let doc = Document (Box 0 0 1 1) (1, 1) (smallArrayFromList shs) 0 False + in fmap (toList . documentShapes) (parseSvg (encodeSvg doc)) === Right shs + ] + +-- | A shape 'parseSvg' could have produced: some segments, and a style +-- within the ranges it clamps to. +genShape :: Gen Shape +genShape = Shape <$> (smallArrayFromList <$> listOf1 segment) <*> matrix <*> style + where + point = Point <$> arbitrary <*> arbitrary + segment = + oneof + [ MoveTo <$> point + , LineTo <$> point + , CubicTo <$> point <*> point <*> point + , QuadTo <$> point <*> point + , ArcTo <$> (abs <$> arbitrary) <*> (abs <$> arbitrary) <*> arbitrary <*> arbitrary <*> arbitrary <*> point + , pure ClosePath + ] + matrix = oneof [pure identity, Matrix <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary] + paint = oneof [pure PaintNone, pure PaintCurrent, PaintColor <$> (rgba <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)] + unit = choose (0, 1) + style = + Style + <$> liftArbitrary paint + <*> (Just <$> paint) + <*> (abs <$> arbitrary) + <*> elements [CapButt, CapRound, CapSquare] + <*> elements [JoinMiter, JoinRound, JoinBevel] + <*> ((1 +) . abs <$> arbitrary) + <*> elements [NonZero, EvenOdd] + <*> unit + <*> unit + <*> unit + +-------------------------------------------------------------------------------- +-- Fixtures +-------------------------------------------------------------------------------- + +-- | A Lucide-style icon: the shape the overwhelming majority of icon sets +-- take, down to the comment in the middle. +clock :: ByteString +clock = + "\ + \" + +holed :: ByteString +holed = + "\ + \" + +rectangles :: ByteString +rectangles = + "" + +polys :: ByteString +polys = + "" + +useDoc :: ByteString +useDoc = + "\ + \" + +symbolDoc :: ByteString +symbolDoc = + "\ + \" + +twiceDoc :: ByteString +twiceDoc = + "\ + \" + +-- | A group that refers to itself @n@ times and also draws one rectangle. +circularFanout :: Int -> ByteString +circularFanout n = + "" + <> mconcat (replicate n "") + <> "" + +-- | @n@ nested uses, the innermost of a rectangle. +useChain :: Int -> ByteString +useChain n = + build $ + "" + <> foldMap (\i -> "") [1 .. n - 1] + <> "" + +-- | A use of @n@ levels of groups, each drawing the one below it twice, +-- over a rectangle: @2^n@ rectangles at @n + 1@ nested uses. +fanout :: Int -> ByteString +fanout n = + build $ + "" + <> foldMap group [1 .. n] + <> "" + where + group i = "" <> use <> use <> "" + where + use = "" + +build :: B.Builder -> ByteString +build = BS.toStrict . B.toLazyByteString + +circular :: ByteString +circular = + "\ + \" + +switchDoc :: ByteString +switchDoc = + "a description is not a drawing\ + \" + +sizeOf :: ByteString -> (Float, Float) +sizeOf = either (error "parse failed") documentSize . parseSvg + +boxOf :: ByteString -> Box +boxOf = either (error "parse failed") documentViewBox . parseSvg + +shapesOf :: ByteString -> [Shape] +shapesOf = either (error "parse failed") (toList . documentShapes) . parseSvg + +-- | The one shape a document was meant to have. +oneShape :: ByteString -> Shape +oneShape src = case shapesOf src of + [sh] -> sh + shs -> error ("expected one shape, got " <> show (length shs))