diagrams-input 0.1.1 → 0.1.2

raw patch · 7 files changed

+84/−77 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +0/−1
• diagrams-input.cabal +2/−2
• src/Diagrams/SVG/Attributes.hs +0/−9
• src/Diagrams/SVG/Path.hs +23/−13
• src/Diagrams/SVG/ReadSVG.hs +42/−42
• src/Diagrams/TwoD/Input.hs +9/−10

@@ -1,3 +1,11 @@+# v0.1.2 (14 June 2023)++- Add new function `readSVGLBS` to read an SVG directly from a lazy+  `ByteString` (thanks to Igor Moreno)+- Fix parsing bug that was causing some paths to be read+  incorrectly ([#17](https://github.com/diagrams/diagrams-input/issues/17))+- Test with GHC 9.6+ # v0.1.1 (8 Jan 2023)  - Fix example in documentation

@@ -42,7 +42,6 @@ ### TODO - [ ] fill = "none" => path open - [ ] Scale viewbox to width and height-- [ ] Bug in arc command - [ ] marker tag - [ ] Transform exceptions into Left values in Image.hs (if monad transformers and conduit is easy for you please help me) - [ ] inherit-attribute

@@ -1,5 +1,5 @@ Name:                diagrams-input-Version:             0.1.1+Version:             0.1.2 Synopsis:            Parse raster and SVG files for diagrams Description:         Parse raster and SVG images for the diagrams DSL. License:             BSD3@@ -11,7 +11,7 @@ Build-type:          Simple Cabal-version:       >=1.10 Extra-source-files:  CHANGELOG.md, README.md-tested-with:         GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.1+tested-with:         GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.1 Source-repository head   type:     git   location: http://github.com/diagrams/diagrams-input.git

@@ -171,15 +171,6 @@                 | otherwise = Nothing pp = parseDouble . pack -myDouble = AT.choice [dotDouble, double]--dotDouble =-   do AT.skipSpace-      AT.char '.'-      frac <- AT.decimal-      let denominator = fromIntegral (10^(length $ digits 10 frac))-      return ((fromIntegral frac) / denominator)- parsePoints :: RealFloat n => Text -> [(n, n)] parsePoints t = either (const []) id (AT.parseOnly (many' parsePoint) t) 

@@ -13,6 +13,7 @@     , outline     , nextSegment     , svgArc+    , myDouble     -- * Parsing (Generating Path Commands)     , PathCommand(..)     , parsePathCommand@@ -23,19 +24,20 @@ import Data.Attoparsec.Combinator import Data.Attoparsec.Text import qualified Data.Attoparsec.Text as AT-import Data.Char (isAlpha, isHexDigit, digitToInt)+import Data.Char (digitToInt, isAlpha, isHexDigit) import Data.Colour.Names (readColourName) import Data.Colour.SRGB-import qualified Data.List.Split as S+import Data.Digits (digits) import Data.List (foldl')-import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes)+import qualified Data.List.Split as S+import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing, maybeToList)+import Data.Text (Text (..), empty, pack, unpack) import qualified Data.Text as T-import Data.Text(Text(..), pack, unpack, empty) import Diagrams.Attributes import Diagrams.Path+import Diagrams.Prelude import Diagrams.Segment import Diagrams.TwoD.Types-import Diagrams.Prelude  data AbsRel = Abs | Rel deriving Show data PathCommand n =@@ -91,10 +93,19 @@                              AT.choice [ do { AT.char a; b <- parser; return b},                                          do {            b <- parser; return b} ] } -doubleWithOptional a = do { d <- double `withOptional` a ; return (fromRational $ toRational d) }+myDouble = AT.choice [dotDouble, double] -spaceDouble = do { AT.skipSpace; d <- double; return (fromRational $ toRational d) }+dotDouble =+   do AT.skipSpace+      AT.char '.'+      frac <- AT.decimal+      let denominator = fromIntegral (10^(length $ digits 10 frac))+      return ((fromIntegral frac) / denominator) +doubleWithOptional a = do { d <- myDouble `withOptional` a ; return (fromRational $ toRational d) }++spaceDouble = do { AT.skipSpace; d <- myDouble; return (fromRational $ toRational d) }+ tuple2 = do { a <- spaceDouble; b <- doubleWithOptional ','; return (a, b) }  tuple4 = do { a <- spaceDouble;@@ -212,22 +223,22 @@ nextSegment ((cx,cy), (x0,y0), O trail) (T Abs (x,y)) = ((2*x0-cx, 2*y0-cy ), (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x-x0, y-y0) (x-x0, y-y0)]) nextSegment ((cx,cy), (x0,y0), O trail) (T Rel (x,y)) = ((2*x0-cx, 2*y0-cy),  (x, y), O $ trail ++ [bez3 (x0-cx, y0-cy) (x, y) (x, y)]) -nextSegment (_, (x0,y0), O trail) (A Abs (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)])-nextSegment (_, (x0,y0), O trail) (A Rel (rx,ry,xAxisRot,fl0,fl1,x,y) ) = (nul, nul, O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)])--nul = (0,0)+nextSegment (_, (x0,y0), O trail) (A Abs (rx,ry,xAxisRot,fl0,fl1,x,y) ) = ((x, y), (x, y), O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x-x0, y-y0)])+nextSegment (_, (x0,y0), O trail) (A Rel (rx,ry,xAxisRot,fl0,fl1,x,y) ) = ((x+x0, y+y0), (x+x0, y+y0), O $ trail ++ [svgArc (rx,ry) xAxisRot fl0 fl1 (x, y)])  straight' = lineFromSegments . (:[]) . straight . r2  bez3 point1 point2 point3 = lineFromSegments [bezier3 (r2 point1) (r2 point2) (r2 point3)]  -- | The arc command: see <http://www.w3.org/TR/SVG11/implnote.html#ArcImplementationNotes>+-- Conversion from endpoint to center parametrization, see B.2.4 -- To Do: scale if rx,ry,xAxisRot are such that there is no solution svgArc :: (RealFloat n, Show n) => (n, n) -> n -> n -> n -> (n,n) -> Trail' Line V2 n svgArc (rxx, ryy) xAxisRot largeArcFlag sweepFlag (x2, y2)      | x2 == 0 && y2 == 0 = emptyLine -- spec F6.2      | rx == 0 || ry == 0 = straight' (x2,y2) -- spec F6.2      | otherwise = -- Debug.Trace.trace (show (dtheta) ++ show dir1) $+-- https://hackage.haskell.org/package/diagrams-lib-1.4.6/docs/Diagrams-TwoD-Arc.html                    unLoc (arc' 1 dir1 (dtheta @@ rad) # scaleY ry # scaleX rx # rotate (phi @@ rad))   where rx | rxx < 0   = -rxx  -- spec F6.2            | otherwise =  rxx@@ -252,7 +263,7 @@             | otherwise =   root * ry * x1' / rx         cx = (cos phi) * cx' - (sin phi) * cy' + ((x1+x2)/2)         cy = (sin phi) * cx' + (cos phi) * cy' + ((y1+y2)/2)-        dir1 = dirBetween (p2 ((x1'-cx')/rx, (y1'-cy')/ry)) origin+        dir1 = dirBetween origin (p2 ((x1'-cx')/rx, (y1'-cy')/ry))         v1 = r2 (( x1'-cx')/rx,  (y1'-cy')/ry)         v2 = r2 ((-x1'-cx')/rx, (-y1'-cy')/ry)         -- angleV1V2 is unfortunately necessary probably because of something like <https://ghc.haskell.org/trac/ghc/ticket/10010>@@ -261,4 +272,3 @@                   | otherwise = (signedAngleBetween v2 v1) ^. rad         dtheta | fs == 0   = if angleV1V2 > 0 then angleV1V2 - (2*pi) else angleV1V2                | otherwise = if angleV1V2 < 0 then angleV1V2 + (2*pi) else angleV1V2-

@@ -125,7 +125,7 @@              => Filesystem.Path.FilePath -> IO (Either String (Diagram b)) readSVGFile fp = if (extension fp) == (Just "svg")     then catchAny (runResourceT $ do-           tree <- parseFile def (encodeString fp) $$ force "error in parseSVG: " parseSVG+           tree <- runConduit $ parseFile def (encodeString fp) .| force "error in parseSVG: " parseSVG            pure $ Right $ diagram tree)          $ \e -> pure $ Left $ "error in parseFile: " <> show e      else pure $ Left "Not a svg file"@@ -174,8 +174,8 @@  -- | Parse \<svg\>, see <http://www.w3.org/TR/SVG/struct.html#SVGElement> parseSVG :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) -          => Sink Event m (Maybe (Tag b n))-parseSVG = tagName "{http://www.w3.org/2000/svg}svg" svgAttrs $+          => ConduitT Event Void m (Maybe (Tag b n))+parseSVG = tag' (Text.XML.Stream.Parse.anyOf ["svg", "{http://www.w3.org/2000/svg}svg"]) svgAttrs $    \(cpa,ca,gea,pa,class_,style,ext,x,y,w,h,vb,ar,zp,ver,baseprof,cScripT,cStyleT,xmlns,xml) ->    do gs <- many gContent       let st hmaps = (parseStyles style hmaps) ++ -- parse the style attribute (style="stop-color:#000000;stop-opacity:0.8")@@ -192,7 +192,7 @@                             (reverse gs)  svgContent :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) -            => Consumer Event m (Maybe (Tag b n))+            => ConduitT Event Void m (Maybe (Tag b n)) svgContent = choose -- the likely most common are checked first      [parseG, parsePath, parseCircle, parseRect, parseEllipse, parseLine, parsePolyLine, parsePolygon,       parseDefs, parseSymbol, parseUse, -- structural elements@@ -203,7 +203,7 @@ --------------------------------------------------------------------------- -- | Parse \<g\>, see <http://www.w3.org/TR/SVG/struct.html#GElement> parseG :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) -        => Consumer Event m (Maybe (Tag b n))+        => forall o. ConduitT Event o m (Maybe (Tag b n)) parseG = tagName "{http://www.w3.org/2000/svg}g" gAttrs    $ \(cpa,ca,gea,pa,class_,style,ext,tr) ->    do insideGs <- many gContent@@ -218,7 +218,7 @@                             (reverse insideGs)  gContent :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) -          => Consumer Event m (Maybe (Tag b n))+          => forall o. ConduitT Event o m (Maybe (Tag b n)) gContent = choose -- the likely most common are checked first      [parsePath, parseG, parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePolygon,       parseUse, parseSymbol, parseStyle, parseDefs, -- structural elements@@ -230,7 +230,7 @@ --------------------------------------------------------------------------- -- | Parse \<defs\>, see <http://www.w3.org/TR/SVG/struct.html#DefsElement> parseDefs :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) -           => Consumer Event m (Maybe (Tag b n))+           => forall o. ConduitT Event o m (Maybe (Tag b n)) parseDefs = tagName "{http://www.w3.org/2000/svg}defs" gAttrs $    \(cpa,ca,gea,pa,class_,style,ext,tr) ->    do insideDefs <- many gContent@@ -253,7 +253,7 @@ --    .fil1 {fill:#3A73B8} --   ]]> --  </style>-parseStyle :: (MonadThrow m, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseStyle :: (MonadThrow m, RealFloat n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseStyle = tagName "{http://www.w3.org/2000/svg}style" sAttrs $    \(ca,type_,media,title) ->    do insideStyle <- content@@ -266,7 +266,7 @@ ----------------------------------------------------------------------------------- -- | Parse \<symbol\>, see <http://www.w3.org/TR/SVG/struct.html#SymbolElement> parseSymbol :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) -             => Consumer Event m (Maybe (Tag b n))+             => forall o. ConduitT Event o m (Maybe (Tag b n)) parseSymbol = tagName "{http://www.w3.org/2000/svg}symbol" symbolAttrs $    \(ca,gea,pa,class_,style,ext,ar,viewbox) ->    do insideSym <- many gContent@@ -282,7 +282,7 @@  ----------------------------------------------------------------------------------- -- | Parse \<use\>, see <http://www.w3.org/TR/SVG/struct.html#UseElement>-parseUse :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Typeable n) => Consumer Event m (Maybe (Tag b n))+parseUse :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Typeable n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseUse = tagName "{http://www.w3.org/2000/svg}use" useAttrs    $ \(ca,cpa,gea,pa,xlink,class_,style,ext,tr,x,y,w,h) ->    do -- insideUse <- many useContent@@ -300,23 +300,23 @@                                                                  p (vbH, miny) 0 y))) .                                                  (applyTr (parseTr tr)) . (applyStyleSVG st maps) -useContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+useContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => forall o. ConduitT Event o m (Maybe (Tag b n)) useContent = choose [parseDesc,parseTitle] -- descriptive elements  -------------------------------------------------------------------------------------- -- | Parse \<switch\>, see <http://www.w3.org/TR/SVG/struct.html#SwitchElement>-parseSwitch :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseSwitch :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseSwitch = tagName "{http://www.w3.org/2000/svg}switch" switchAttrs    $ \(cpa,ca,gea,pa,class_,style,ext,tr) ->    do -- insideSwitch <- many switchContent       return $ Leaf (id1 ca) mempty mempty --- switchContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+-- switchContent :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => forall o. ConduitT Event o m (Maybe (Tag b n)) switchContent = choose [parsePath, parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePolygon]  ----------------------------------------------------------------------------------- -- | Parse \<rect\>,  see <http://www.w3.org/TR/SVG11/shapes.html#RectElement>-parseRect :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseRect :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseRect = tagName "{http://www.w3.org/2000/svg}rect" rectAttrs $   \(cpa,ca,gea,pa,class_,style,ext,ar,tr,x,y,w,h,rx,ry) -> do     let st hmaps = (parseStyles style hmaps) ++@@ -334,7 +334,7 @@  --------------------------------------------------------------------------------------------------- -- | Parse \<circle\>,  see <http://www.w3.org/TR/SVG11/shapes.html#CircleElement>-parseCircle :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseCircle :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseCircle = tagName "{http://www.w3.org/2000/svg}circle" circleAttrs $   \(cpa,ca,gea,pa,class_,style,ext,tr,r,cx,cy) -> do     let -- st :: (RealFloat n, RealFloat a, Read a) => (HashMaps b n, ViewBox n) -> [SVGStyle n a]@@ -349,7 +349,7 @@  --------------------------------------------------------------------------------------------------- -- | Parse \<ellipse\>,  see <http://www.w3.org/TR/SVG11/shapes.html#EllipseElement>-parseEllipse :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseEllipse :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseEllipse = tagName "{http://www.w3.org/2000/svg}ellipse" ellipseAttrs $   \(cpa,ca,gea,pa,class_,style,ext,tr,rx,ry,cx,cy) -> do     let st hmaps = (parseStyles style hmaps) ++@@ -363,7 +363,7 @@  --------------------------------------------------------------------------------------------------- -- | Parse \<line\>,  see <http://www.w3.org/TR/SVG11/shapes.html#LineElement>-parseLine :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parseLine :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseLine = tagName "{http://www.w3.org/2000/svg}line" lineAttrs $   \(cpa,ca,gea,pa,class_,style,ext,tr,x1,y1,x2,y2) -> do     let st hmaps = (parseStyles style hmaps) ++@@ -379,7 +379,7 @@  --------------------------------------------------------------------------------------------------- -- | Parse \<polyline\>,  see <http://www.w3.org/TR/SVG11/shapes.html#PolylineElement>-parsePolyLine :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parsePolyLine :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parsePolyLine = tagName "{http://www.w3.org/2000/svg}polyline" polygonAttrs $   \(cpa,ca,gea,pa,class_,style,ext,tr,points) -> do     let st hmaps = (parseStyles style hmaps) ++@@ -397,7 +397,7 @@  -------------------------------------------------------------------------------------------------- -- | Parse \<polygon\>,  see <http://www.w3.org/TR/SVG11/shapes.html#PolygonElement>-parsePolygon :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parsePolygon :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parsePolygon = tagName "{http://www.w3.org/2000/svg}polygon" polygonAttrs $   \(cpa,ca,gea,pa,class_,style,ext,tr,points) -> do     let st hmaps = (parseStyles style hmaps) ++@@ -415,7 +415,7 @@  -------------------------------------------------------------------------------------------------- -- | Parse \<path\>,  see <http://www.w3.org/TR/SVG11/paths.html#PathElement>-parsePath :: (MonadThrow m, InputConstraints b n, Show n) => Consumer Event m (Maybe (Tag b n))+parsePath :: (MonadThrow m, InputConstraints b n, Show n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parsePath = tagName "{http://www.w3.org/2000/svg}path" pathAttrs $   \(cpa,ca,gea,pa,class_,style,ext,tr,d,pathLength) -> do     let st hmaps = (parseStyles style hmaps) ++@@ -429,7 +429,7 @@ ------------------------------------------------------------------------------------------------- -- | Parse \<clipPath\>, see <http://www.w3.org/TR/SVG/masking.html#ClipPathElement> parseClipPath :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) -               => Consumer Event m (Maybe (Tag b n))+               => forall o. ConduitT Event o m (Maybe (Tag b n)) parseClipPath = tagName "{http://www.w3.org/2000/svg}clipPath" clipPathAttrs $   \(cpa,ca,pa,class_,style,ext,ar,viewbox) -> do     insideClipPath <- many clipPathContent@@ -444,7 +444,7 @@                      (reverse insideClipPath)  clipPathContent :: (MonadThrow m, InputConstraints b n, Show n, Read n, Renderable (TT.Text n) b) -                 => Consumer Event m (Maybe (Tag b n))+                 => forall o. ConduitT Event o m (Maybe (Tag b n)) clipPathContent = choose [parseRect, parseCircle, parseEllipse, parseLine, parsePolyLine, parsePath,                           parsePolygon, parseText, parseUse] @@ -452,7 +452,7 @@ -- | Parse \<image\>, see <http://www.w3.org/TR/SVG/struct.html#ImageElement> -- <image width="28" xlink:href="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABwAAAADCAYAAACAjW/aAAAABmJLR0QA/wD/AP+gvaeTAAAAB3RJTUUH2AkMDx4ErQ9V0AAAAClJREFUGJVjYMACGhoa/jMwMPyH0kQDYvQxYpNsaGjAyibCQrL00dSHACypIHXUNrh3AAAAAElFTkSuQmCC" height="3"/> parseImage :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Renderable (DImage (N b) Embedded) b,-              Typeable b, Typeable n) => Consumer Event m (Maybe (Tag b n))+              Typeable b, Typeable n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseImage = tagName "{http://www.w3.org/2000/svg}image" imageAttrs $   \(ca,cpa,gea,xlink,pa,class_,style,ext,ar,tr,x,y,w,h) ->   do return $ Leaf (id1 ca) mempty (\(_,(minx,miny,vbW,vbH)) -> (dataUriToImage (xlinkHref xlink) (p (minx,vbW) 0 w) (p (miny,vbH) 0 h))@@ -498,7 +498,7 @@ ------------------------------------------------------------------------------------------------- -- | Parse \<text\>, see <http://www.w3.org/TR/SVG/text.html#TextElement> parseText :: (MonadThrow m, InputConstraints b n, Read n, RealFloat n, Renderable (TT.Text n) b)-            => Consumer Event m (Maybe (Tag b n))+            => forall o. ConduitT Event o m (Maybe (Tag b n)) parseText = tagName "{http://www.w3.org/2000/svg}text" textAttrs $   \(cpa,ca,gea,pa,class_,style,ext,tr,la,x,y,dx,dy,rot,textlen) ->     do let st hmaps = (parseStyles style hmaps) ++@@ -636,7 +636,7 @@ -- | Parse \<linearGradient\>, see <http://www.w3.org/TR/SVG/pservers.html#LinearGradientElement> -- example: <linearGradient id="SVGID_2_" gradientUnits="userSpaceOnUse" x1="68.2461" y1="197.6797" --           x2="52.6936" y2="237.5337" gradientTransform="matrix(1 0 0 -1 -22.5352 286.4424)">-parseLinearGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseLinearGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseLinearGradient = tagName "{http://www.w3.org/2000/svg}linearGradient" linearGradAttrs $   \(ca,pa,xlink,class_,style,ext,x1,y1,x2,y2,gradientUnits,gradientTransform,spreadMethod) -> -- TODO gradientUnits   do gs <- many gradientContent@@ -660,7 +660,7 @@    --   parseDesc, parseMetaData, parseTitle] -- descriptive Elements (rarely used here, so tested at the end)  -- | Parse \<radialGradient\>, see <http://www.w3.org/TR/SVG/pservers.html#RadialGradientElement>-parseRadialGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseRadialGradient :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseRadialGradient = tagName "{http://www.w3.org/2000/svg}radialGradient" radialGradAttrs $ -- TODO gradientUnits   \(ca,pa,xlink,class_,style,ext,cx,cy,r,fx,fy,gradientUnits,gradientTransform,spreadMethod) ->    do gs <- many gradientContent@@ -731,7 +731,7 @@ ----------------------------------------------------------------------------------------------------  parseFont :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Renderable (DImage (N b) Embedded) b, Renderable (Path V2 n) b,-              Typeable b, Typeable n, Show n, Read n, Renderable (TT.Text n) b) => Consumer Event m (Maybe (Tag b n))+              Typeable b, Typeable n, Show n, Read n, Renderable (TT.Text n) b) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseFont = tagName "{http://www.w3.org/2000/svg}font" fontAttrs $   \(ca,pa,class_,style,ext,hOriginX,hOriginY,hAdvX,vOriginX,vOriginY,vAdvY) ->   do gs <- many fontContent@@ -755,13 +755,13 @@         toSvgGlyph (GG (Glyph glyphId g d horizAdvX _ _ _ (Just unicode) glyphName o a l)) = (unicode,(glyphName,horizAdvX,d))  fontContent :: (MonadThrow m, InputConstraints b n, Read n, Show n, Renderable (TT.Text n) b) -             => Consumer Event m (Maybe (FontContent b n))+             => forall o. ConduitT Event o m (Maybe (FontContent b n)) fontContent = choose -- the likely most common are checked first      [parseGlyph, parseHKern, parseFontFace, parseMissingGlyph, parseVKern]   parseFontFace :: (MonadThrow m, V b ~ V2, N b ~ n, Read n, RealFloat n, Renderable (DImage (N b) Embedded) b,-              Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+              Typeable b, Typeable n) => forall o. ConduitT Event o m (Maybe (FontContent b n)) parseFontFace = tagName "{http://www.w3.org/2000/svg}font-face" fontFaceAttrs $   \(ca,fontFamily,fontStyle,fontVariant,fontWeight,fontStretch,fontSize,unicodeRange,unitsPerEm,panose1,     stemv,stemh,slope,capHeight,xHeight,accentHeight,ascent,descent,widths,bbox,ideographic,alphabetic,mathematical,@@ -774,7 +774,7 @@   parseMissingGlyph :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Renderable (DImage (N b) Embedded) b,-              Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+              Typeable b, Typeable n) => forall o. ConduitT Event o m (Maybe (FontContent b n)) parseMissingGlyph = tagName "{http://www.w3.org/2000/svg}missing-glyph" missingGlyphAttrs $   \(ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY) ->   do return $ GG $ Glyph (id1 ca) (Leaf (id1 ca) mempty mempty) Nothing@@ -784,7 +784,7 @@  parseGlyph :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Renderable (DImage (N b) Embedded) b,               Renderable (Path V2 n) b, Show n, Typeable b, Typeable n, Renderable (TT.Text n) b) -           => Consumer Event m (Maybe (FontContent b n))+           => forall o. ConduitT Event o m (Maybe (FontContent b n)) parseGlyph = tagName "{http://www.w3.org/2000/svg}glyph" glyphAttrs $   \(ca,pa,class_,style,d,horizAdvX,vertOriginX,vertOriginY,vertAdvY,unicode,glyphName,orientation,arabicForm,lang) ->   do gs <- many gContent@@ -795,12 +795,12 @@  getN = maybe 0 (read . T.unpack) -parseHKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+parseHKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => forall o. ConduitT Event o m (Maybe (FontContent b n)) parseHKern = tagName "{http://www.w3.org/2000/svg}hkern" kernAttrs $   \(ca,u1,g1,u2,g2,k) ->   do return $ KK $ Kern HKern (charList u1) (charList g1) (charList u2) (charList g2) (getN k) -parseVKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => Consumer Event m (Maybe (FontContent b n))+parseVKern :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n, Read n, Typeable b, Typeable n) => forall o. ConduitT Event o m (Maybe (FontContent b n)) parseVKern = tagName "{http://www.w3.org/2000/svg}vkern" kernAttrs $   \(ca,u1,g1,u2,g2,k) ->   do return $ KK $ Kern VKern (charList u1) (charList g1) (charList u2) (charList g2) (getN k)@@ -812,7 +812,7 @@ -- descriptive elements ------------------------------------------------------o	---------------------------------- -- | Parse \<desc\>, see <http://www.w3.org/TR/SVG/struct.html#DescriptionAndTitleElements>--- parseDesc :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+-- parseDesc :: (MonadThrow m, Metric (V b), RealFloat (N b)) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseDesc = tagName "{http://www.w3.org/2000/svg}desc" descAttrs    $ \(ca,class_,style) ->    do desc <- content@@ -824,7 +824,7 @@    do title <- content       return $ Leaf (id1 ca) mempty mempty -skipArbitraryTag :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) => Consumer Event m (Maybe (Tag b n))+skipArbitraryTag :: (MonadThrow m, InputConstraints b n, Renderable (TT.Text n) b, Read n) => forall o. ConduitT Event o m (Maybe (Tag b n)) skipArbitraryTag = do t <- ignoreAnyTreeContent                       if isJust t then return (Just $ Leaf (Just "") mempty mempty)                                   else return Nothing@@ -849,22 +849,22 @@ -- {-  Maybe we implement it one day -parseMetaData :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => Consumer Event m (Maybe (Tag b n))+parseMetaData :: (MonadThrow m, V b ~ V2, N b ~ n, RealFloat n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseMetaData = tagName "{http://www.w3.org/2000/svg}metadata" ignoreAttrs    $ \_ ->    do -- meta <- many metaContent       return $ Leaf Nothing mempty mempty --- metaContent :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+-- metaContent :: (MonadThrow m, Metric (V b), RealFloat (N b)) => forall o. ConduitT Event o m (Maybe (Tag b n)) metaContent = choose [parseRDF] -- extend if needed --- parseRDF :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+-- parseRDF :: (MonadThrow m, Metric (V b), RealFloat (N b)) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseRDF = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}RDF" ignoreAttrs           $ \_ ->           do -- c <- parseWork              return $ Leaf Nothing mempty mempty --- parseWork :: (MonadThrow m, Metric (V b), RealFloat (N b)) => Consumer Event m (Maybe (Tag b n))+-- parseWork :: (MonadThrow m, Metric (V b), RealFloat (N b)) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseWork = tagName "{http://creativecommons.org/ns#}Work" ignoreAttrs    $ \_ ->    do -- c <- many workContent@@ -885,7 +885,7 @@ parseSubject = tagName "{http://purl.org/dc/elements/1.1/}subject" ignoreAttrs    $ \_ -> do { c <- parseBag ; return $ Leaf Nothing mempty mempty } --- parseBag :: (MonadThrow m, Metric (V b), Ord (N b), Floating (N b)) => Consumer Event m (Maybe (Tag b n))+-- parseBag :: (MonadThrow m, Metric (V b), Ord (N b), Floating (N b)) => forall o. ConduitT Event o m (Maybe (Tag b n)) parseBag = tagName "{http://www.w3.org/1999/02/22-rdf-syntax-ns#}Bag" ignoreAttrs    $ \_ -> do { c <- parseList ; return $ Leaf Nothing mempty mempty } @@ -951,13 +951,13 @@ -- sceletons  -- | Parse \<pattern\>, see <http://www.w3.org/TR/SVG/pservers.html#PatternElement>-parsePattern :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+parsePattern :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) parsePattern = tagName "{http://www.w3.org/2000/svg}pattern" patternAttrs $   \(cpa,ca,pa,class_,style,ext,view,ar,x,y,w,h,pUnits,pCUnits,pTrans) ->   do c <- content -- insidePattern <- many patternContent      return $ Leaf (Just "") mempty mempty -patternContent :: (MonadThrow m, InputConstraints b n) => Consumer Event m (Maybe (Tag b n))+patternContent :: (MonadThrow m, InputConstraints b n) => forall o. ConduitT Event o m (Maybe (Tag b n)) patternContent = choose [parseImage]  -- | Parse \<filter\>, see <http://www.w3.org/TR/SVG/filters.html#FilterElement>

@@ -19,6 +19,7 @@ import           Codec.Picture import           Codec.Picture.Types  (dynamicMap) +import           Data.Either (isRight) import           Data.Semigroup import           Data.Typeable        (Typeable) @@ -33,23 +34,21 @@  -- | Load 2d formats given by a filepath and embed them loadImageEmbedded :: (InputConstraints b n, Renderable (TT.Text n) b, Read n, n ~ Place) -                   => String -> IO (Either String (QDiagram b V2 n Any))+                   => FilePath -> IO (Either String (QDiagram b V2 n Any)) loadImageEmbedded path = do   dImg <- readImage path   svgImg <- readSVGFile (decodeString path)-  return $ msum  [ svgImg,-                   fmap (image.rasterImage) dImg ] -- skip "Left"s and use the first "Right" image-  where-    rasterImage img = DImage (ImageRaster img) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty+  return $ if isRight svgImg then svgImg else fmap (image.rasterImage) dImg+ where+   rasterImage img = DImage (ImageRaster img) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty  -- | Load 2d formats given by a filepath and make a reference loadImageExternal :: (InputConstraints b n, Renderable (DImage n External) b)                     => FilePath -> IO (Either String (QDiagram b V2 n Any)) loadImageExternal path = do+  --  svgImg <- readSVGFile (decodeString path)   dImg <- readImage path---  svgImg <- readSVGFile path-  return $ msum [ fmap (image.rasterPath) dImg ]---                svgImg ] -- skip "Left"s and use the first "Right" image-  where-    rasterPath img = DImage (ImageRef path) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty+  return $ fmap (image.rasterPath) dImg+ where+   rasterPath img = DImage (ImageRef path) (dynamicMap imageWidth img) (dynamicMap imageHeight img) mempty