nano-svg 0.1.0.0 → 0.2.0.0

raw patch · 13 files changed

+1610/−2723 lines, 13 filesdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−5
• LICENSE +20/−20
• README.md +66/−68
• lib/Graphics/NanoSvg.hs +336/−331
• lib/Graphics/NanoSvg/Attribute.hs +282/−0
• lib/Graphics/NanoSvg/Color.hs +0/−371
• lib/Graphics/NanoSvg/Internal/Parser.hs +0/−179
• lib/Graphics/NanoSvg/Number.hs +0/−262
• lib/Graphics/NanoSvg/Path.hs +0/−290
• lib/Graphics/NanoSvg/Types.hs +165/−362
• lib/Graphics/NanoSvg/Xml.hs +0/−185
• nano-svg.cabal +91/−94
• test/Main.hs +626/−556

@@ -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.

@@ -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.

@@ -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+```

@@ -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 =+  "<svg xmlns=\"http://www.w3.org/2000/svg\""+    <> attribute "width" (number w)+    <> attribute "height" (number h)+    <> attribute "viewBox" (spaced (map number [x, y, bw, bh]))+    <> ">"+    <> foldMap shape (documentShapes doc)+    <> "</svg>"+  where+    Box x y bw bh = documentViewBox doc+    (w, h) = documentSize doc++shape :: Shape -> B.Builder+shape (Shape segs m s) =+  "<path"+    <> 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 "<?" (X.outer c))]+  where+    element c = el+      where+        el = Element (local (X.name c)) [(local k, entities v) | X.Attribute k v <- X.attributes c] (smallArrayFromList (segments el)) (nodes c)+    local s = maybe s (\i -> 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" s+    decl = if BC.elem '[' (BC.takeWhile (/= '>') 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+

@@ -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"

@@ -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)
-  ]

@@ -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

@@ -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 #-}

@@ -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]

@@ -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 = "<svg " <> 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 = "<svg " <> show (documentSize doc) <> ">"

@@ -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 "<?" (Hexml.outer n))]
-    element node =
-      Element
-        { elementName = localName (Hexml.name node)
-        , elementAttributes =
-            [ Attribute
-                { attributeName = localName (Hexml.attributeName a)
-                , attributeValue = decodeEntities (Hexml.attributeValue a)
-                }
-            | a <- Hexml.attributes node
-            ]
-        , elementChildren = map element (elements node)
-        }
-
---------------------------------------------------------------------------------
--- Looking things up
---------------------------------------------------------------------------------
-
--- | Find the first attribute with the given local name (case-sensitive).
--- On a parsed tree, @"href"@ also matches an original @xlink:href@.
-attribute :: ByteString -> 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 "<!DOCTYPE" bytes of
-  (_, rest) | BS.null rest -> 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 "&amp;" s = Just (B.word8 0x26, r)
-  | Just r <- BS.stripPrefix "&lt;" s = Just (B.word8 0x3C, r)
-  | Just r <- BS.stripPrefix "&gt;" s = Just (B.word8 0x3E, r)
-  | Just r <- BS.stripPrefix "&quot;" s = Just (B.word8 0x22, r)
-  | Just r <- BS.stripPrefix "&apos;" 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)

@@ -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

@@ -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 "<svg width='1e400' height='1e400'/>" @?= (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 "<a x='1'><b/></a>"
-          @?= Right [Element "a" [Attribute "x" "1"] [Element "b" [] []]]
-    , testCase "namespace prefixes are dropped" $
-        fmap (map elementName) (parseXml "<svg:svg><svg:path/></svg:svg>")
-          @?= Right ["svg"]
-    , testCase "comments and instructions are not in the tree" $
-        fmap (map elementName) (parseXml "<?xml version='1.0'?><!--hi--><a/>")
-          @?= Right ["a"]
-    , testCase "a doctype is stepped over" $
-        fmap (map elementName) (parseXml "<!DOCTYPE svg PUBLIC \"x\" \"y\"><svg/>")
-          @?= Right ["svg"]
-    , testCase "including one with an internal subset" $
-        fmap (map elementName) (parseXml "<!DOCTYPE svg [<!ENTITY x \"y\">]><svg/>")
-          @?= Right ["svg"]
-    , testCase "and so is a byte-order mark" $
-        fmap (map elementName) (parseXml "\xEF\xBB\xBF<svg/>")
-          @?= Right ["svg"]
-    , testCase "entities in attribute values" do
-        decodeEntities "a&amp;b" @?= "a&b"
-        decodeEntities "&lt;&gt;&quot;&apos;" @?= "<>\"'"
-        decodeEntities "&#65;&#x42;&#X43;" @?= "ABC"
-        decodeEntities "&#x2713;" @?= "\xE2\x9C\x93"
-        decodeEntities "plain" @?= "plain"
-        decodeEntities "50% &amp; 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 "<a><b></a>"))
-    ]
-
-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 "<nope/>"))
-        assertBool "expected a Left" (isLeft (parseSvg "not xml at all"))
-    , testCase "the size and the box" do
-        sizeOf "<svg width='48' height='32'/>" @?= (48, 32)
-        sizeOf "<svg viewBox='0 0 24 24'/>" @?= (24, 24)
-        sizeOf "<svg width='48' height='48' viewBox='0 0 24 24'/>" @?= (48, 48)
-        sizeOf "<svg width='1in' height='1in'/>" @?= (96, 96)
-        -- A percentage is not a length, so the viewBox decides.
-        sizeOf "<svg width='100%' height='100%' viewBox='0 0 16 16'/>" @?= (16, 16)
-        sizeOf "<svg/>" @?= (24, 24)
-        boxOf "<svg viewBox='1 2 24 25'/>" @?= Box 1 2 24 25
-        -- A viewBox that is not four numbers, or has no extent, is not one.
-        boxOf "<svg width='8' height='9' viewBox='0 0 24'/>" @?= Box 0 0 8 9
-        boxOf "<svg width='8' height='9' viewBox='0 0 24 24 24'/>" @?= Box 0 0 8 9
-        boxOf "<svg width='8' height='9' viewBox='0 0 0 24'/>" @?= 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 "<svg><rect width='1' height='1'/></svg>")
-          @?= Right True
-    , testCase "presentation attributes are inherited" $
-        let sh =
-              oneShape "<svg stroke-width='3'><g stroke='red'><path d='M0 0L1 1'/></g></svg>"
-         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 "<svg><path fill='red' style='fill: blue' d='M0 0L1 1'/></svg>"
-         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 "<svg fill='red'><path fill='url(#grad)' d='M0 0L1 1'/></svg>"
-         in styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255))
-    , testCase "an opacity may be a percentage" do
-        styleOpacity (shapeStyle (oneShape "<svg><path opacity='50%' d='M0 0L1 1'/></svg>"))
-          @?= 0.5
-        styleFillOpacity
-          (shapeStyle (oneShape "<svg><path fill-opacity='25%' d='M0 0L1 1'/></svg>"))
-          @?= 0.25
-    , testCase "opacity multiplies down the tree" $
-        let sh = oneShape "<svg opacity='0.5'><g opacity='0.5'><path d='M0 0L1 1'/></g></svg>"
-         in styleOpacity (shapeStyle sh) @?= 0.25
-    , testCase "and a style attribute outranks a presentation one there too" $
-        styleOpacity
-          ( shapeStyle
-              (oneShape "<svg><path opacity='0.5' style='opacity:0.25' d='M0 0L1 1'/></svg>")
-          )
-          @?= 0.25
-    , testCase "a switch draws the first child that draws anything" do
-        map (length . toList . shapeSegments) (shapesOf switchDoc) @?= [2]
-        shapesOf "<svg><switch><desc>nothing here</desc></switch></svg>" @?= []
-    , testCase "transforms compose down it" $
-        let sh =
-              oneShape
-                "<svg><g transform='translate(5 0)'><g transform='scale(2)'><path d='M1 1L1 1'/></g></g></svg>"
-         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 "<svg><circle r='5'/><ellipse rx='5' ry='3'/></svg>")
-          @?= [4, 4]
-        map
-          (length . toList . shapeSegments)
-          (shapesOf "<svg><line x2='5' y2='5'/></svg>")
-          @?= [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 "<svg><rect width='0' height='5'/></svg>" @?= []
-        shapesOf "<svg><circle r='0'/></svg>" @?= []
-        shapesOf "<svg><path d=''/></svg>" @?= []
-    , testCase "defs are not drawn where they stand" $
-        shapesOf "<svg><defs><rect id='r' width='1' height='1'/></defs></svg>" @?= []
-    , 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 "<svg><g display='none'><rect width='1' height='1'/></g></svg>" @?= []
-        shapesOf "<svg><rect style='display:none' width='1' height='1'/></svg>" @?= []
-        shapesOf "<svg><g visibility='hidden'><rect width='1' height='1'/></g></svg>"
-          @?= []
-        length
-          (shapesOf "<svg><g visibility='visible'><rect width='1' height='1'/></g></svg>")
-          @?= 1
-    , testCase "and a style declaration outranks the attribute there too" do
-        length
-          ( shapesOf
-              "<svg><rect display='none' style='display:inline' width='1' height='1'/></svg>"
-          )
-          @?= 1
-        shapesOf
-          "<svg><rect display='inline' style='display:none' width='1' height='1'/></svg>"
-          @?= []
-    , testCase "text, gradients and the rest are skipped" $
-        shapesOf
-          "<svg><text x='0'>hi</text><linearGradient id='g'/><foreignObject/></svg>"
-          @?= []
-    , 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 =
-  "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"24\" height=\"24\" viewBox=\"0 0 24 24\" fill=\"none\" \
-  \stroke=\"currentColor\" stroke-width=\"2\" stroke-linecap=\"round\" stroke-linejoin=\"round\">\
-  \<!-- a clock --><circle cx=\"12\" cy=\"12\" r=\"10\"/><path d=\"M12 6v6l4 2\"/></svg>"
-
-holed :: ByteString
-holed =
-  "<svg viewBox='0 0 10 10'><path fill-rule='evenodd' fill='#ff0000' d='M0 0h10v10H0z M3 3h4v4H3z'/>\
-  \<g transform='translate(5 0) scale(0.5)'><rect width='2' height='2' fill='rgb(0,0,255)'/></g></svg>"
-
-rectangles :: ByteString
-rectangles =
-  "<svg><rect width='4' height='4'/><rect width='4' height='4' rx='1'/></svg>"
-
-polys :: ByteString
-polys =
-  "<svg><polyline points='0,0 1,1'/><polygon points='0,0 1,0 1,1'/></svg>"
-
-useDoc :: ByteString
-useDoc =
-  "<svg><defs><rect id='r' width='1' height='1'/></defs>\
-  \<use xlink:href='#r' x='5' y='6' fill='red'/></svg>"
-
-symbolDoc :: ByteString
-symbolDoc =
-  "<svg><symbol id='s'><rect width='1' height='1'/><circle r='1'/></symbol>\
-  \<use href='#s'/></svg>"
-
-twiceDoc :: ByteString
-twiceDoc =
-  "<svg><defs><rect id='r' width='1' height='1'/></defs>\
-  \<use href='#r'/><use href='#r' x='5'/></svg>"
-
--- | A group that refers to itself @n@ times and also draws one rectangle.
-circularFanout :: Int -> ByteString
-circularFanout n =
-  "<svg><defs><g id='a'>"
-    <> mconcat (replicate n "<use href='#a'/>")
-    <> "<rect width='1' height='1'/></g></defs><use href='#a'/></svg>"
-
-circular :: ByteString
-circular =
-  "<svg><defs><g id='a'><use href='#b'/></g><g id='b'><use href='#a'/>\
-  \<rect width='1' height='1'/></g></defs><use href='#a'/></svg>"
-
-switchDoc :: ByteString
-switchDoc =
-  "<svg><switch><desc>a description is not a drawing</desc>\
-  \<line x2='1' y2='1'/><rect width='9' height='9'/></switch></svg>"
-
-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 "<svg><path stroke-width='1em' d='M0 0L1 1'/></svg>")) @?= 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 "<svg width='1e400' height='1e400'/>" @?= (24, 24)+    , testCase "an odd point is dropped" $+        map (toList . shapeSegments) (shapesOf "<svg><polyline points='0,0 1,1 2'/></svg>")+          @?= [[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 "<svg:svg><svg:rect width='1' height='1'/></svg:svg>") @?= 1+        length (shapesOf useDoc) @?= 1+    , testCase "comments, instructions, doctypes and byte-order marks are skipped" do+        sizeOf "<?xml version='1.0'?><!--hi--><svg width='3'/>" @?= (3, 24)+        sizeOf "<!DOCTYPE svg PUBLIC \"x\" \"y\"><svg width='3'/>" @?= (3, 24)+        sizeOf "<!DOCTYPE svg [<!ENTITY x \"y\">]><svg width='3'/>" @?= (3, 24)+        sizeOf "<svg width='3'/>" @?= (3, 24)+    , testCase "entities in attribute values" do+        styleFill (shapeStyle (oneShape "<svg><path fill='&#x72;&#101;&#X64;' d='M0 0L1 1'/></svg>"))+          @?= Just (PaintColor (rgba 255 0 0 255))+        map (length . toList . shapeSegments) (shapesOf "<svg><path d='M0 0&#10;L1 1'/></svg>") @?= [2]+    , testCase "an ampersand that begins nothing stands for itself" $+        map (length . toList . shapeSegments) (shapesOf "<svg><path d='M0 0 &amp L1 1 &nosuch; &#;'/></svg>")+          @?= [1]+    , testCase "and so does a reference past the last code point" $+        -- Would wrap around to 'r' in 64-bit arithmetic.+        styleFill (shapeStyle (oneShape "<svg><path fill='&#x10000000000000072;ed' d='M0 0L1 1'/></svg>"))+          @?= Nothing+    , testCase "a document that is not one" $+        assertBool "expected a Left" (isLeft (parseSvg "<svg><b></svg>"))+    ]++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 "<nope/>"))+        assertBool "expected a Left" (isLeft (parseSvg "not xml at all"))+    , testCase "the size and the box" do+        sizeOf "<svg width='48' height='32'/>" @?= (48, 32)+        sizeOf "<svg viewBox='0 0 24 24'/>" @?= (24, 24)+        sizeOf "<svg width='48' height='48' viewBox='0 0 24 24'/>" @?= (48, 48)+        sizeOf "<svg width='1in' height='1in'/>" @?= (96, 96)+        -- A percentage is not a length, so the viewBox decides.+        sizeOf "<svg width='100%' height='100%' viewBox='0 0 16 16'/>" @?= (16, 16)+        sizeOf "<svg/>" @?= (24, 24)+        boxOf "<svg viewBox='1 2 24 25'/>" @?= Box 1 2 24 25+        -- A viewBox that is not four numbers, or has no extent, is not one.+        boxOf "<svg width='8' height='9' viewBox='0 0 24'/>" @?= Box 0 0 8 9+        boxOf "<svg width='8' height='9' viewBox='0 0 24 24 24'/>" @?= Box 0 0 8 9+        boxOf "<svg width='8' height='9' viewBox='0 0 0 24'/>" @?= 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 "<svg><rect width='1' height='1'/></svg>")+          @?= Right True+    , testCase "presentation attributes are inherited" $+        let sh =+              oneShape "<svg stroke-width='3'><g stroke='red'><path d='M0 0L1 1'/></g></svg>"+         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 "<svg><path fill='red' style='fill: blue' d='M0 0L1 1'/></svg>"+         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 "<svg fill='red'><path fill='url(#grad)' d='M0 0L1 1'/></svg>"+         in styleFill (shapeStyle sh) @?= Just (PaintColor (rgba 255 0 0 255))+    , testCase "an opacity may be a percentage" do+        styleOpacity (shapeStyle (oneShape "<svg><path opacity='50%' d='M0 0L1 1'/></svg>"))+          @?= 0.5+        styleFillOpacity+          (shapeStyle (oneShape "<svg><path fill-opacity='25%' d='M0 0L1 1'/></svg>"))+          @?= 0.25+    , testCase "opacity multiplies down the tree" $+        let sh = oneShape "<svg opacity='0.5'><g opacity='0.5'><path d='M0 0L1 1'/></g></svg>"+         in styleOpacity (shapeStyle sh) @?= 0.25+    , testCase "and a style attribute outranks a presentation one there too" $+        styleOpacity+          ( shapeStyle+              (oneShape "<svg><path opacity='0.5' style='opacity:0.25' d='M0 0L1 1'/></svg>")+          )+          @?= 0.25+    , testCase "a switch draws the first child that draws anything" do+        map (length . toList . shapeSegments) (shapesOf switchDoc) @?= [2]+        shapesOf "<svg><switch><desc>nothing here</desc></switch></svg>" @?= []+    , testCase "transforms compose down it" $+        let sh =+              oneShape+                "<svg><g transform='translate(5 0)'><g transform='scale(2)'><path d='M1 1L1 1'/></g></g></svg>"+         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 "<svg><circle r='5'/><ellipse rx='5' ry='3'/></svg>")+          @?= [4, 4]+        map+          (length . toList . shapeSegments)+          (shapesOf "<svg><line x2='5' y2='5'/></svg>")+          @?= [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 "<svg><rect width='0' height='5'/></svg>" @?= []+        shapesOf "<svg><circle r='0'/></svg>" @?= []+        shapesOf "<svg><path d=''/></svg>" @?= []+    , testCase "defs are not drawn where they stand" $+        shapesOf "<svg><defs><rect id='r' width='1' height='1'/></defs></svg>" @?= []+    , 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 "<svg><defs><line id='d' x2='1'/><rect id='d' width='1' height='1'/></defs><use href='#d'/></svg>")+          @?= [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 "<svg><g display='none'><rect width='1' height='1'/></g></svg>" @?= []+        shapesOf "<svg><rect style='display:none' width='1' height='1'/></svg>" @?= []+        shapesOf "<svg><g visibility='hidden'><rect width='1' height='1'/></g></svg>"+          @?= []+        length+          (shapesOf "<svg><g visibility='visible'><rect width='1' height='1'/></g></svg>")+          @?= 1+    , testCase "and a style declaration outranks the attribute there too" do+        length+          ( shapesOf+              "<svg><rect display='none' style='display:inline' width='1' height='1'/></svg>"+          )+          @?= 1+        shapesOf+          "<svg><rect display='inline' style='display:none' width='1' height='1'/></svg>"+          @?= []+    , testCase "text, gradients and the rest are skipped" $+        shapesOf+          "<svg><text x='0'>hi</text><linearGradient id='g'/><foreignObject/></svg>"+          @?= []+    , 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)+          @?= "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"10\" height=\"10\" viewBox=\"0 0 10 10\">\+              \<path d=\"M0 0 L10 0 L10 10 L0 10 Z M3 3 L7 3 L7 7 L3 7 Z\" fill=\"#ff0000\" fill-rule=\"evenodd\"/>\+              \<path d=\"M0 0 L2 0 L2 2 L0 2 Z\" transform=\"matrix(0.5 0 0 0.5 5 0)\" fill=\"#0000ff\"/></svg>"+    , testCase "a translucent color keeps its alpha, and a fraction its digits" $+        either error encodeSvg (parseSvg "<svg viewBox='0 0 1 1'><path fill='#12345678' stroke-width='0.1' d='M1e-3 0L1e8 0'/></svg>")+          @?= "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"1\" height=\"1\" viewBox=\"0 0 1 1\">\+              \<path d=\"M1.0e-3 0 L1.0e8 0\" fill=\"#12345678\" stroke-width=\"0.1\"/></svg>"+    , 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 =+  "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"24\" height=\"24\" viewBox=\"0 0 24 24\" fill=\"none\" \+  \stroke=\"currentColor\" stroke-width=\"2\" stroke-linecap=\"round\" stroke-linejoin=\"round\">\+  \<!-- a clock --><circle cx=\"12\" cy=\"12\" r=\"10\"/><path d=\"M12 6v6l4 2\"/></svg>"++holed :: ByteString+holed =+  "<svg viewBox='0 0 10 10'><path fill-rule='evenodd' fill='#ff0000' d='M0 0h10v10H0z M3 3h4v4H3z'/>\+  \<g transform='translate(5 0) scale(0.5)'><rect width='2' height='2' fill='rgb(0,0,255)'/></g></svg>"++rectangles :: ByteString+rectangles =+  "<svg><rect width='4' height='4'/><rect width='4' height='4' rx='1'/></svg>"++polys :: ByteString+polys =+  "<svg><polyline points='0,0 1,1'/><polygon points='0,0 1,0 1,1'/></svg>"++useDoc :: ByteString+useDoc =+  "<svg><defs><rect id='r' width='1' height='1'/></defs>\+  \<use xlink:href='#r' x='5' y='6' fill='red'/></svg>"++symbolDoc :: ByteString+symbolDoc =+  "<svg><symbol id='s'><rect width='1' height='1'/><circle r='1'/></symbol>\+  \<use href='#s'/></svg>"++twiceDoc :: ByteString+twiceDoc =+  "<svg><defs><rect id='r' width='1' height='1'/></defs>\+  \<use href='#r'/><use href='#r' x='5'/></svg>"++-- | A group that refers to itself @n@ times and also draws one rectangle.+circularFanout :: Int -> ByteString+circularFanout n =+  "<svg><defs><g id='a'>"+    <> mconcat (replicate n "<use href='#a'/>")+    <> "<rect width='1' height='1'/></g></defs><use href='#a'/></svg>"++-- | @n@ nested uses, the innermost of a rectangle.+useChain :: Int -> ByteString+useChain n =+  build $+    "<svg><defs>"+      <> foldMap (\i -> "<use id='u" <> B.intDec i <> "' href='#u" <> B.intDec (i + 1) <> "'/>") [1 .. n - 1]+      <> "<rect id='u" <> B.intDec n <> "' width='1' height='1'/></defs><use href='#u1'/></svg>"++-- | 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 $+    "<svg><defs><rect id='g0' width='1' height='1'/>"+      <> foldMap group [1 .. n]+      <> "</defs><use href='#g" <> B.intDec n <> "'/></svg>"+  where+    group i = "<g id='g" <> B.intDec i <> "'>" <> use <> use <> "</g>"+      where+        use = "<use href='#g" <> B.intDec (i - 1) <> "'/>"++build :: B.Builder -> ByteString+build = BS.toStrict . B.toLazyByteString++circular :: ByteString+circular =+  "<svg><defs><g id='a'><use href='#b'/></g><g id='b'><use href='#a'/>\+  \<rect width='1' height='1'/></g></defs><use href='#a'/></svg>"++switchDoc :: ByteString+switchDoc =+  "<svg><switch><desc>a description is not a drawing</desc>\+  \<line x2='1' y2='1'/><rect width='9' height='9'/></switch></svg>"++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))