diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,10 @@ ## Unreleased +## 0.6.3.0 + +- the SVG CSS now declares the Path fill opacity as 0 + ## 0.6.2.1 ## 0.6.2.0 diff --git a/src/Waterfall/SVG/FromSVG.hs b/src/Waterfall/SVG/FromSVG.hs --- a/src/Waterfall/SVG/FromSVG.hs +++ b/src/Waterfall/SVG/FromSVG.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} {-| Load [SVG Data](https://developer.mozilla.org/en-US/docs/Web/SVG) into `Waterfall.Path2D` -} @@ -21,13 +22,22 @@ import Control.Lens ((^.), ala, each) import Data.Monoid (Endo (..)) import Control.Arrow (second) -import Data.Foldable (foldl') +import Prelude hiding (Foldable(..)) +import Data.Foldable (Foldable(..)) +import Control.Exception (IOException, try) import Control.Monad (join, (<=<)) +import Data.Bifunctor (first) import Data.Maybe (catMaybes) import Data.Function ((&)) -- | Categories of error that may occur when processing an SVG -data SVGErrorKind = SVGIOError | SVGParseError | SVGPathError | SVGTransformError | SVGNumberError +data SVGErrorKind + = SVGIOError + | SVGTreeError + | SVGParseError + | SVGPathError + | SVGTransformError + | SVGNumberError deriving (Eq, Ord, Show) -- | Type representing an error that occured when processing an SVG @@ -322,6 +332,8 @@ -- | Load an SVG file into a `Waterfall.Path2D` readSVG :: FilePath -> IO (Either SVGError [Waterfall.Path2D]) -readSVG path = - let fileReadErr = Left . SVGError SVGIOError $ "Failed to read svg from file: " <> path - in ( convertDocument <=< maybe fileReadErr Right) <$> Svg.loadSvgFile path +readSVG path = + let fileReadErr = Left . SVGError SVGTreeError $ "Failed to parse svg tree in file: " <> path + fileOpenErr = SVGError SVGIOError . show @IOException + in (convertDocument <=< maybe fileReadErr Right <=< first fileOpenErr) + <$> try (Svg.loadSvgFile path) diff --git a/src/Waterfall/SVG/ToSVG.hs b/src/Waterfall/SVG/ToSVG.hs --- a/src/Waterfall/SVG/ToSVG.hs +++ b/src/Waterfall/SVG/ToSVG.hs @@ -11,7 +11,8 @@ import qualified Waterfall import qualified Graphics.Svg as Svg import qualified Graphics.Svg.CssTypes as Svg.Css -import Linear (_xy, _x, _y, V2 (..), nearZero) +import Waterfall.Internal.NearZero (nearZero) +import Linear (_xy, _x, _y, V2 (..)) import Control.Lens ((^.), (&), (.~)) import Foreign.Ptr (Ptr) import Control.Monad ((<=<)) @@ -111,7 +112,7 @@ edgeToPathCommand curPos edge = Internal.Finalizers.unsafeFromAcquire $ do startPos <- liftIO $ (^. _xy) <$> Internal.Edges.edgeValue edge 0 endPos <- liftIO $ (^. _xy) <$> Internal.Edges.edgeValue edge 1 - let hasntMoved = nearZero . (startPos -) <$> curPos + let hasntMoved = all nearZero . (startPos -) <$> curPos let addMoveCommand = case hasntMoved of Just True -> id @@ -155,7 +156,9 @@ styles = [ Svg.Css.CssRule [[Svg.Css.AllOf [Svg.Css.OfClass "edge"]]] - [Svg.Css.CssDeclaration "fill" [[Svg.Css.CssIdent "None"]]] + [ Svg.Css.CssDeclaration "fill" [[Svg.Css.CssIdent "None"]] + , Svg.Css.CssDeclaration "fill-opacity" [[Svg.Css.CssNumber (Svg.Num 0)]] + ] , Svg.Css.CssRule [[Svg.Css.AllOf [Svg.Css.OfClass "edge", Svg.Css.OfClass "visible"]]] [Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor $ PixelRGBA8 0 0 0 255]]] diff --git a/test-data/fixture1.svg b/test-data/fixture1.svg new file mode 100644 --- /dev/null +++ b/test-data/fixture1.svg @@ -0,0 +1,24 @@ + + + + + + + + + diff --git a/test-data/fixture2.svg b/test-data/fixture2.svg new file mode 100644 --- /dev/null +++ b/test-data/fixture2.svg diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} + +import Control.Monad (void, (<=<)) +import Data.Either (isRight) +import Paths_waterfall_cad_svg (getDataFileName) +import Test.Tasty +import Test.Tasty.HUnit +import Waterfall.SVG + +readTestFile :: FilePath -> IO (Either SVGError ()) +readTestFile = fmap void . readSVG <=< getDataFileName + +shouldSatisfy :: Show a => a -> (a -> Bool) -> Assertion +shouldSatisfy x p = assertBool ("predicate failed for " <> show x) $ p x + +main :: IO () +main = defaultMain $ + testGroup "readSVG" $ + [ testCase "reads a good file successfully" $ do + result <- readTestFile "test-data/fixture1.svg" + result `shouldSatisfy` isRight + , testCase "returns SVGTreeError from a bad file" $ do + result <- readTestFile "test-data/fixture2.svg" + result `shouldSatisfy` \case + Left (SVGError SVGTreeError _) -> True + _ -> False + , testCase "returns SVGIOError from a non-existent file" $ do + result <- readTestFile "does-not-exist.svg" + result `shouldSatisfy` \case + Left (SVGError SVGIOError _) -> True + _ -> False + ] diff --git a/waterfall-cad-svg.cabal b/waterfall-cad-svg.cabal --- a/waterfall-cad-svg.cabal +++ b/waterfall-cad-svg.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: waterfall-cad-svg -version: 0.6.2.1 +version: 0.6.3.0 synopsis: Declarative CAD/Solid Modeling Library, SVG Support description: Please see the README on GitHub at category: Graphics @@ -21,6 +21,9 @@ LICENSE README.md CHANGELOG.md +data-files: + test-data/fixture1.svg + test-data/fixture2.svg source-repository head type: git @@ -42,9 +45,33 @@ , base >=4.7 && <5 , lens ==5.* , linear >=1.0 && <2 - , opencascade-hs >=0.6.2.1 && <0.7 + , opencascade-hs >=0.6.3.0 && <0.7 , resourcet >=1.2 && <1.4 , svg-tree >=0.6 && <1 , text >=1.2 && <3 - , waterfall-cad >=0.6.2.1 && <0.7 + , waterfall-cad >=0.6.3.0 && <0.7 + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_waterfall_cad_svg + hs-source-dirs: + test + ghc-options: -Wall -Werror=compat -Werror=identities -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=missing-home-modules -Werror=missing-export-lists -Werror=partial-fields -Werror=redundant-constraints -optc -Werror-implicit-function-declaration + build-depends: + JuicyPixels ==3.* + , attoparsec >=0.14 && <1 + , base >=4.7 && <5 + , lens ==5.* + , linear >=1.0 && <2 + , opencascade-hs >=0.6.3.0 && <0.7 + , resourcet >=1.2 && <1.4 + , svg-tree >=0.6 && <1 + , tasty + , tasty-hunit + , text >=1.2 && <3 + , waterfall-cad >=0.6.3.0 && <0.7 + , waterfall-cad-svg default-language: Haskell2010