diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,8 @@ ## Unreleased +## 0.6.3.0 + ## 0.6.2.1 ## 0.6.2.0 diff --git a/src/CsgExample.hs b/src/CsgExample.hs --- a/src/CsgExample.hs +++ b/src/CsgExample.hs @@ -8,7 +8,7 @@ import qualified Waterfall.Solids as Solids import qualified Waterfall.Transforms as Transforms import Waterfall.Booleans ( union, intersection, difference ) -import Linear (V3 (..), (^*), unit, _x, _y ) +import Linear (V3 (..), unit, _x, _y ) import Data.Function ((&)) csgExample :: Solids.Solid diff --git a/src/DarkModeSVG.hs b/src/DarkModeSVG.hs --- a/src/DarkModeSVG.hs +++ b/src/DarkModeSVG.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module DarkModeSVG -( writeDarkModeSVG +( darkModeSVG +, writeDarkModeSVG ) where import qualified Waterfall.SVG @@ -19,6 +20,7 @@ styles = [r| .edge { fill: None; + fill-opacity: 0; } .edge.visible { stroke: #000000; @@ -36,15 +38,15 @@ } |] -writeDarkModeSVG :: FilePath -> Waterfall.Diagram -> IO () -writeDarkModeSVG path diagram = - let svgAsXML = +darkModeSVG :: Waterfall.Diagram -> XML.Element +darkModeSVG diagram = + let svgAsXML = diagram - & Waterfall.SVG.diagramToSvg - & Svg.xmlOfDocument + & Waterfall.SVG.diagramToSvg + & Svg.xmlOfDocument nameIsStyle (XML.Elem e) = (== "style") . XML.qName . XML.elName $ e nameIsStyle _ = False - in svgAsXML + in svgAsXML & XML.Cursor.fromElement & XML.Cursor.findChild (nameIsStyle . XML.Cursor.current) & fmap XML.Cursor.firstChild @@ -56,6 +58,11 @@ & XML.Proc.onlyElems & listToMaybe & fromMaybe svgAsXML - & XML.Output.ppTopElement - & writeFile path + +writeDarkModeSVG :: FilePath -> Waterfall.Diagram -> IO () +writeDarkModeSVG path diagram = + diagram + & darkModeSVG + & XML.Output.ppTopElement + & writeFile path diff --git a/src/FilletExample.hs b/src/FilletExample.hs --- a/src/FilletExample.hs +++ b/src/FilletExample.hs @@ -16,7 +16,6 @@ , indexedConditionalChamfer , whenNearlyEqual ) -import Control.Lens ((^.)) import Linear (V3 (..), _xy) import Control.Monad (guard) diff --git a/src/GearExample.hs b/src/GearExample.hs --- a/src/GearExample.hs +++ b/src/GearExample.hs @@ -12,6 +12,7 @@ -} module GearExample ( gearExample +, playgroundGearExample ) where import qualified Waterfall.Solids as Solids @@ -44,8 +45,9 @@ chebyApprox :: (Double -> Double) -> Int -> [Double] chebyApprox f p' = let fnCoeffs = [chebyExpnCoeffs k f | k <- [0..p'] ] - adjust 0 = head fnCoeffs /2 - adjust _ = 0 + adjust p + | p == 0, (c : _) <- fnCoeffs = c / 2 + | otherwise = 0 in [ sum [fnCoeffs!!k * (cheby !! k !! pwr) | k <- [0..p'] ] - adjust pwr | pwr <- [0..p'] ] binom :: Int -> Int -> Double @@ -147,3 +149,7 @@ path = Path2D.repeatLooping segment --path = mconcat [rotate2D (-fromIntegral n * pi * 2 / fromIntegral nGears) segment | n <- [0..nGears]] in Solids.prism thickness . Shape.makeShape $ path + +-- | This is intended to be viewed via the WASM playground +playgroundGearExample :: Solids.Solid +playgroundGearExample = gearExample 10 5 20 (20*pi/180) diff --git a/src/LoftExample.hs b/src/LoftExample.hs --- a/src/LoftExample.hs +++ b/src/LoftExample.hs @@ -39,8 +39,7 @@ mirror = Transforms.mirror (V3 1 0 0 ) . Path.reversePath makeSymetric p = mirror p <> p symetricPaths = makeSymetric <$> paths - body = - Loft.pointedLoft + body = Loft.pointedLoft Nothing (Path.closeLoop <$> symetricPaths) (Just (V3 0 20 5)) diff --git a/src/TakePathFractionExample.hs b/src/TakePathFractionExample.hs --- a/src/TakePathFractionExample.hs +++ b/src/TakePathFractionExample.hs @@ -12,6 +12,7 @@ import qualified Waterfall.Transforms as Transforms import qualified Waterfall.TwoD.Transforms as TwoD.Transforms import Linear (V3 (..), zero) +import Data.Function ((&)) takePathFractionExample :: Solid takePathFractionExample = @@ -24,6 +25,8 @@ profile = TwoD.Transforms.uScale2D 0.2 Shape.unitCircle fractions = [0.1, 0.2 .. 1.0] in mconcat - [ Transforms.translate (V3 (f * 10) 0 0) . sweep (Path.takePathFraction3D f sweepPath) $ profile + [ profile + & sweep (Path.takePathFraction3D f sweepPath) + & Transforms.translate (V3 (f * 10) 0 0) | f <- fractions ] diff --git a/src/TextExample.hs b/src/TextExample.hs --- a/src/TextExample.hs +++ b/src/TextExample.hs @@ -2,12 +2,18 @@ <> -} module TextExample ( - textExample + textExample, + playgroundTextExample ) where import qualified Waterfall import Linear (unit, _x) + textExample :: FilePath -> Double -> String -> Double -> IO Waterfall.Solid textExample fontpath fontSize content depth = do font <- Waterfall.fontFromPath fontpath fontSize return . Waterfall.rotate (unit _x) (pi/2) . Waterfall.prism depth $ Waterfall.text font content + +-- | This is intended to be viewed via the WASM playground +playgroundTextExample :: IO Waterfall.Solid +playgroundTextExample = textExample "/VarelaRound-Regular.ttf" 24 "Waterfall-CAD" 12 diff --git a/test-data/2d-booleans.svg b/test-data/2d-booleans.svg new file mode 100644 --- /dev/null +++ b/test-data/2d-booleans.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/bounding-boxes.svg b/test-data/bounding-boxes.svg new file mode 100644 --- /dev/null +++ b/test-data/bounding-boxes.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/csg.svg b/test-data/csg.svg new file mode 100644 --- /dev/null +++ b/test-data/csg.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/fillet.svg b/test-data/fillet.svg new file mode 100644 --- /dev/null +++ b/test-data/fillet.svg @@ -0,0 +1,29 @@ + + + + + + + + + + diff --git a/test-data/fonts/varela/OFL.txt b/test-data/fonts/varela/OFL.txt new file mode 100644 --- /dev/null +++ b/test-data/fonts/varela/OFL.txt @@ -0,0 +1,93 @@ +Copyright 2023 The Varela Round Project Authors (https://github.com/alefalefalef/Varela-Round-Hebrew/), with Reserved Font Names 'Varela' and ‘Varela Round’. + +This Font Software is licensed under the SIL Open Font License, Version 1.1. +This license is copied below, and is also available with a FAQ at: +https://openfontlicense.org + + +----------------------------------------------------------- +SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 +----------------------------------------------------------- + +PREAMBLE +The goals of the Open Font License (OFL) are to stimulate worldwide +development of collaborative font projects, to support the font creation +efforts of academic and linguistic communities, and to provide a free and +open framework in which fonts may be shared and improved in partnership +with others. + +The OFL allows the licensed fonts to be used, studied, modified and +redistributed freely as long as they are not sold by themselves. The +fonts, including any derivative works, can be bundled, embedded, +redistributed and/or sold with any software provided that any reserved +names are not used by derivative works. The fonts and derivatives, +however, cannot be released under any other type of license. The +requirement for fonts to remain under this license does not apply +to any document created using the fonts or their derivatives. + +DEFINITIONS +"Font Software" refers to the set of files released by the Copyright +Holder(s) under this license and clearly marked as such. This may +include source files, build scripts and documentation. + +"Reserved Font Name" refers to any names specified as such after the +copyright statement(s). + +"Original Version" refers to the collection of Font Software components as +distributed by the Copyright Holder(s). + +"Modified Version" refers to any derivative made by adding to, deleting, +or substituting -- in part or in whole -- any of the components of the +Original Version, by changing formats or by porting the Font Software to a +new environment. + +"Author" refers to any designer, engineer, programmer, technical +writer or other person who contributed to the Font Software. + +PERMISSION & CONDITIONS +Permission is hereby granted, free of charge, to any person obtaining +a copy of the Font Software, to use, study, copy, merge, embed, modify, +redistribute, and sell modified and unmodified copies of the Font +Software, subject to the following conditions: + +1) Neither the Font Software nor any of its individual components, +in Original or Modified Versions, may be sold by itself. + +2) Original or Modified Versions of the Font Software may be bundled, +redistributed and/or sold with any software, provided that each copy +contains the above copyright notice and this license. These can be +included either as stand-alone text files, human-readable headers or +in the appropriate machine-readable metadata fields within text or +binary files as long as those fields can be easily viewed by the user. + +3) No Modified Version of the Font Software may use the Reserved Font +Name(s) unless explicit written permission is granted by the corresponding +Copyright Holder. This restriction only applies to the primary font name as +presented to the users. + +4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font +Software shall not be used to promote, endorse or advertise any +Modified Version, except to acknowledge the contribution(s) of the +Copyright Holder(s) and the Author(s) or with their explicit written +permission. + +5) The Font Software, modified or unmodified, in part or in whole, +must be distributed entirely under this license, and must not be +distributed under any other license. The requirement for fonts to +remain under this license does not apply to any document created +using the Font Software. + +TERMINATION +This license becomes null and void if any of the above conditions are +not met. + +DISCLAIMER +THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT +OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE +COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM +OTHER DEALINGS IN THE FONT SOFTWARE. diff --git a/test-data/fonts/varela/VarelaRound-Regular.ttf b/test-data/fonts/varela/VarelaRound-Regular.ttf new file mode 100644 Binary files /dev/null and b/test-data/fonts/varela/VarelaRound-Regular.ttf differ diff --git a/test-data/gear.svg b/test-data/gear.svg new file mode 100644 --- /dev/null +++ b/test-data/gear.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/loft.svg b/test-data/loft.svg new file mode 100644 --- /dev/null +++ b/test-data/loft.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/negativeScaledCube-II.svg b/test-data/negativeScaledCube-II.svg new file mode 100644 --- /dev/null +++ b/test-data/negativeScaledCube-II.svg @@ -0,0 +1,29 @@ + + + + + + + + + + diff --git a/test-data/negativeScaledCube-III.svg b/test-data/negativeScaledCube-III.svg new file mode 100644 --- /dev/null +++ b/test-data/negativeScaledCube-III.svg @@ -0,0 +1,29 @@ + + + + + + + + + + diff --git a/test-data/negativeScaledCube.svg b/test-data/negativeScaledCube.svg new file mode 100644 --- /dev/null +++ b/test-data/negativeScaledCube.svg @@ -0,0 +1,29 @@ + + + + + + + + + + diff --git a/test-data/negativeScaledCuboid.svg b/test-data/negativeScaledCuboid.svg new file mode 100644 --- /dev/null +++ b/test-data/negativeScaledCuboid.svg @@ -0,0 +1,29 @@ + + + + + + + + + + diff --git a/test-data/offset.svg b/test-data/offset.svg new file mode 100644 --- /dev/null +++ b/test-data/offset.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/platonic.svg b/test-data/platonic.svg new file mode 100644 --- /dev/null +++ b/test-data/platonic.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/revolution.svg b/test-data/revolution.svg new file mode 100644 --- /dev/null +++ b/test-data/revolution.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/sweep.svg b/test-data/sweep.svg new file mode 100644 --- /dev/null +++ b/test-data/sweep.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/takePathFraction.svg b/test-data/takePathFraction.svg new file mode 100644 --- /dev/null +++ b/test-data/takePathFraction.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-data/text.svg b/test-data/text.svg new file mode 100644 --- /dev/null +++ b/test-data/text.svg @@ -0,0 +1,28 @@ + + + + + + + + + + diff --git a/test-results/.keep b/test-results/.keep new file mode 100644 --- /dev/null +++ b/test-results/.keep diff --git a/test/DiagramGoldenTests.hs b/test/DiagramGoldenTests.hs new file mode 100644 --- /dev/null +++ b/test/DiagramGoldenTests.hs @@ -0,0 +1,223 @@ +module DiagramGoldenTests +( diagramGoldenTests +) where + +import Test.Tasty (TestTree, TestName, testGroup) +import Test.Tasty.Golden.Advanced (goldenTest) +import Text.XML.Light as XML +import DarkModeSVG (darkModeSVG) +import qualified Graphics.Svg as Svg +import Data.Maybe (fromMaybe) +import Waterfall.Diagram (Diagram) +import qualified Waterfall.Diagram as Diagram +import qualified Waterfall.TwoD.Transforms as TwoD.Transforms +import Waterfall.Solids (Solid) +import qualified Waterfall.Solids as Solids +import qualified Waterfall.Transforms as Transforms +import Linear +import qualified CsgExample +import Control.Monad.Except (runExceptT, liftEither) +import qualified Data.ByteString.Char8 as BSC8 +import qualified Graphics.Rasterific.Svg as RSvg +import qualified Graphics.Text.TrueType as FF +import Control.Monad.IO.Class (liftIO) +import Control.Monad (unless, join) +import qualified Codec.Picture as JP +import Control.Lens +import Data.Function (on) +import Data.Monoid (Sum (getSum)) +import System.FilePath (takeBaseName, ()) +import qualified FilletExample +import qualified GearExample +import qualified RevolutionExample +import qualified SweepExample +import qualified OffsetExample +import qualified TextExample +import qualified BoundingBoxExample +import qualified LoftExample +import qualified TwoDBooleansExample +import qualified PlatonicSolidsExample +import qualified TakePathFractionExample +import qualified Paths_waterfall_cad_examples as Paths + +xmlToSvg :: String -> XML.Element -> Either String Svg.Document +xmlToSvg fileDesc = maybe (Left $ "failed to parse " <> fileDesc) Right . Svg.parseSvgFile "file.svg" . BSC8.pack . XML.showTopElement + +-- this is unlawful - it assumes the two images have the same size +zippingTraversal :: JP.Pixel px => Traversal' (JP.Image px, JP.Image px) (px, px) +zippingTraversal = + alongside (partsOf JP.imagePixels) (partsOf JP.imagePixels) + . iso (uncurry zip) unzip + . traverse + +pixelDiffThreshold :: Integer +pixelDiffThreshold = 16 + +pixelCountThreshold :: Integer +pixelCountThreshold = 64 + +comparePixels :: JP.PixelRGBA8 -> JP.PixelRGBA8 -> Bool +comparePixels (JP.PixelRGBA8 r1 g1 b1 a1) (JP.PixelRGBA8 r2 g2 b2 a2) = + let c x y = abs (fromIntegral x - fromIntegral y) + in (c r1 r2 + c g1 g2 + c b1 b2 + c a1 a2 ) < pixelDiffThreshold + +size :: JP.Image px -> (Int, Int) +size a = (JP.imageWidth a, JP.imageHeight a) + +similarSizes :: JP.Image px -> JP.Image px -> Bool +similarSizes a b = + let within1 a b = abs (a - b) <= 1 + in (within1 `on` JP.imageWidth) a b + && (within1 `on` JP.imageHeight) a b + +render :: Svg.Document -> IO (JP.Image JP.PixelRGBA8, RSvg.LoadedElements) +render = RSvg.renderSvgDocument + FF.emptyFontCache + Nothing -- Document Size + 72 -- DPI, a so-so DPI for screens, higher would just mean making the test less sensitive + +countMismatchedPixel :: (JP.PixelRGBA8, JP.PixelRGBA8) -> Sum Integer +countMismatchedPixel (x, y) = if comparePixels x y then 0 else 1 + +colourMismatchedPixel :: (JP.PixelRGBA8, JP.PixelRGBA8) -> JP.PixelRGBA8 +colourMismatchedPixel (x, y) = if comparePixels x y then x else JP.PixelRGBA8 255 0 0 255 + +dup :: a -> (a, a) +dup = join (,) + +cropToSmallest :: JP.Pixel a => JP.Image a -> JP.Image a -> (JP.Image a, JP.Image a) +cropToSmallest a b = + if size a == size b + then (a, b) + else + let w = (min `on` JP.imageWidth) a b + h = (min `on` JP.imageHeight) a b + crop img = JP.generateImage (JP.pixelAt img) w h + in (crop a, crop b) + +compareOutput :: FilePath -> XML.Element -> XML.Element -> IO (Maybe String) +compareOutput inputPath expected actual = + let extract (Left s) = Just s + extract (Right ()) = Nothing + in fmap extract . runExceptT $ do + expectedSvg <- liftEither $ xmlToSvg "expected" expected + actualSvg <- liftEither $ xmlToSvg "actual" actual + (expectedRendered, _) <- liftIO $ render expectedSvg + (actualRendered, _) <- liftIO $ render actualSvg + + projectRoot <- liftIO Paths.getDataDir + + let makePath kind = projectRoot "test-results" takeBaseName inputPath <> "." <> kind <> ".png" + let expectedPath = makePath "expected" + let diffPath = makePath "diff" + let actualPath = makePath "actual" + + unless (similarSizes expectedRendered actualRendered) $ do + liftIO $ JP.writePng expectedPath expectedRendered + liftIO $ JP.writePng actualPath actualRendered + liftEither . Left $ + ( "incompatible sizes, expected: " + <> show (size expectedRendered) + <> ", actual " + <> show (size actualRendered) + <> ", actual written to " + <> actualPath) + + let (expectedRenderedCropped, actualRenderedCropped) = cropToSmallest expectedRendered actualRendered + (width, height) = size expectedRenderedCropped + + + + let mismatchedCount = getSum $ + foldMapOf + zippingTraversal + countMismatchedPixel + (expectedRenderedCropped, actualRenderedCropped) + unless (mismatchedCount < pixelCountThreshold) $ do + let totalPixels = width * height + let diffImage = + (expectedRenderedCropped, actualRenderedCropped) + & zippingTraversal %~ (dup . colourMismatchedPixel) + & (^. _1) + liftIO $ JP.writePng expectedPath expectedRendered + liftIO $ JP.writePng diffPath diffImage + liftIO $ JP.writePng actualPath actualRendered + + liftEither . Left $ + ( show mismatchedCount <> "/" <> show totalPixels + <> " pixels didn't match, diff written to " + <> diffPath + ) + +doTest :: TestName -> FilePath -> IO Diagram -> TestTree +doTest testName goldenPath makeDiagram = + let qualifyGoldenPath = ( "test-data" goldenPath) <$> Paths.getDataDir + readGoldenFile = fromMaybe (error $ "failed to read " <> goldenPath) . parseXMLDoc <$> (readFile =<< qualifyGoldenPath) + -- most paths are relative to Paths_waterfall_cad_examples.getDataDir + -- however when updating the file, we want to modify the source file + -- therefore this is sensitive to the cwd + updateGoldenFile = writeFile ("test-data" goldenPath) . ppTopElement + in goldenTest + testName + readGoldenFile + (darkModeSVG <$> makeDiagram) + (\a b -> do + path <- qualifyGoldenPath + compareOutput path a b + ) + updateGoldenFile + +standardSolidDiagram :: Solid -> Diagram +standardSolidDiagram = withWidth 800 . Diagram.solidDiagram (V3 2 3 1) + +normalizeSize :: (V2 Double -> Double) -> Double -> Diagram -> Diagram +normalizeSize getter target d = + case Diagram.diagramBoundingBox d of + Just (lo, hi) -> + let s = getter (hi - lo) + in TwoD.Transforms.uScale2D (target / s) d + Nothing -> d + +withHeight :: Double -> Diagram -> Diagram +withHeight = normalizeSize (^. _y) + +withWidth :: Double -> Diagram -> Diagram +withWidth = normalizeSize (^. _x) + +solidTest :: TestName -> FilePath -> Solid -> TestTree +solidTest name filepath solid = + doTest name filepath (pure . standardSolidDiagram $ solid) + +smallSolidTest :: TestName -> FilePath -> Solid -> TestTree +smallSolidTest name filepath solid = + doTest name filepath (pure . withHeight 200 . standardSolidDiagram $ solid) + +diagramGoldenTests :: TestTree +diagramGoldenTests = testGroup "Diagram Golden Tests" + [ smallSolidTest "CSG" "csg.svg" CsgExample.csgExample + , solidTest "Gear" "gear.svg" $ GearExample.gearExample 1 5 20 (20*pi/180) + , smallSolidTest "Revolution" "revolution.svg" RevolutionExample.revolutionExample + , smallSolidTest "Sweep" "sweep.svg" SweepExample.sweepExample + , solidTest "Offset" "offset.svg" OffsetExample.offsetExample + , doTest "Text" "text.svg" $ do + projectRoot <- Paths.getDataDir + standardSolidDiagram <$> TextExample.textExample + (projectRoot "test-data/fonts/varela/VarelaRound-Regular.ttf") + 12.0 + "Waterfall-CAD" + 10 + , smallSolidTest "Bound" "bounding-boxes.svg" BoundingBoxExample.boundingBoxExample + , solidTest "Loft" "loft.svg" LoftExample.loftExample + , solidTest "Fillet" "fillet.svg" FilletExample.filletExample + , smallSolidTest "2D Booleans" "2d-booleans.svg" TwoDBooleansExample.twoDBooleansExample + , solidTest "Platonic Solids" "platonic.svg" PlatonicSolidsExample.platonicSolidsExample + , solidTest "Take Path Fraction" "takePathFraction.svg" TakePathFractionExample.takePathFractionExample + , solidTest "Negative Scaled Cube" "negativeScaledCube.svg" + (Transforms.scale (V3 (negate 1) 1 1) Solids.unitCube) + , solidTest "Negative Scaled Cube II" "negativeScaledCube-II.svg" + (Transforms.scale (negate $ V3 1 1 1) Solids.unitCube) + , solidTest "Negative Scaled Cube III" "negativeScaledCube-III.svg" + (Transforms.scale (V3 (negate 10) (negate 10) 10) Solids.unitCube) + , solidTest "Negative Scaled Cuboid" "negativeScaledCuboid.svg" + (Transforms.scale (V3 (negate 1) 2 3) Solids.unitCube) + ] diff --git a/test/ExceptionTests.hs b/test/ExceptionTests.hs new file mode 100644 --- /dev/null +++ b/test/ExceptionTests.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE LambdaCase #-} +module ExceptionTests +( exceptionTests +) where + +import qualified Waterfall.Offset as Offset +import qualified Waterfall.Fillet as Fillet +import qualified Waterfall.Revolution as Revolution +import qualified Waterfall.TwoD.Path2D as Path2D +import qualified Waterfall.Solids as Solids +import Waterfall.Error (WaterfallError (..)) +import Linear (V2 (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit +import OpenCascade.Internal.Exception (OpenCascadeException (..), testThrow) +import OpenCascade.Std.RuntimeError as RuntimeError +import OpenCascade.Inheritance (upcast) +import Control.Exception (catch, Exception) +import Control.Monad (when) +import System.IO.Temp (emptySystemTempFile) +import qualified Waterfall.IO as IO +import Waterfall.IO (WaterfallIOException(WaterfallIOException), WaterfallIOExceptionCause (FileError)) +import Data.Acquire (with) +import Data.Either (fromLeft) + + +checkFailure :: Exception b => IO a -> (b -> Maybe String) -> IO () +checkFailure f check = do + success <- catch (f >> pure True) handler + when success $ assertFailure "Did not catch expected error" + where + handler e = + case check e of + Nothing -> pure False + Just msg -> + assertFailure msg + +expectFailure :: (Exception b, Eq b) => IO a -> b -> IO () +expectFailure f expected = + checkFailure f + (\e -> + if e == expected + then Nothing + else Just $ "Caught unexpected error\n" + <> "expected: " <> show expected + <> "\ngot: " <> show e + ) + + +writeTmpStl :: Solids.Solid -> IO () +writeTmpStl s = do + file <- emptySystemTempFile "solid.stl" + IO.writeSTL 0.1 file s + +exceptionTests :: TestTree +exceptionTests = testGroup "Exception Tests" + [ -- It's a little weird that this fails at IO time, whereas _some_ operations will fail with an OpenCascade exception when the operation is performed + testCase "Bad Offset" $ checkFailure (writeTmpStl $ Offset.offset (negate 1) Solids.centeredCube) + $ \case + WaterfallIOException FileError _ -> Nothing + e -> Just $ "Expected WaterfallIOException\ngot: " <> show e + , testCase "Bad Fillet" $ assertEqual "Bad Fillet" + (fromLeft (error "expected failure") $ Fillet.tryRoundFillet 2 Solids.centeredCube) + (WaterfallError $ OpenCascadeStandardFailure "BRep_API: command not done" "") + , testCase "Bad Revolution" $ assertEqual "Bad Revolution" + (fromLeft (error "expected failure") $ Revolution.tryRevolution + (Path2D.pathFrom (V2 (-1) 0) + [ Path2D.lineTo (V2 1 0) + , Path2D.lineTo (V2 1 2) + , Path2D.lineTo (V2 (-1) 2) + ])) + (WaterfallError $ OpenCascadeStandardFailure "BRep_API: command not done" "") + , testCase "Throw Std Exception" $ with (RuntimeError.new "Some Exception Text") $ \re -> + expectFailure (testThrow (upcast re)) (OpenCascadeStdException "Some Exception Text") + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,14 @@ +module Main +( main +) where + +import DiagramGoldenTests (diagramGoldenTests) +import ExceptionTests (exceptionTests) +import Test.Tasty (defaultMain, testGroup) + + +main :: IO () +main = defaultMain $ testGroup "tests" + [ diagramGoldenTests + , exceptionTests + ] diff --git a/waterfall-cad-examples.cabal b/waterfall-cad-examples.cabal --- a/waterfall-cad-examples.cabal +++ b/waterfall-cad-examples.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.6. -- -- see: https://github.com/sol/hpack name: waterfall-cad-examples -version: 0.6.2.1 +version: 0.6.3.0 synopsis: Examples for Waterfall CAD, a Declarative CAD/Solid Modeling Library description: Please see the README on GitHub at category: Graphics @@ -21,6 +21,26 @@ LICENSE README.md CHANGELOG.md +data-files: + test-data/2d-booleans.svg + test-data/bounding-boxes.svg + test-data/csg.svg + test-data/fillet.svg + test-data/gear.svg + test-data/loft.svg + test-data/negativeScaledCube-II.svg + test-data/negativeScaledCube-III.svg + test-data/negativeScaledCube.svg + test-data/negativeScaledCuboid.svg + test-data/offset.svg + test-data/platonic.svg + test-data/revolution.svg + test-data/sweep.svg + test-data/takePathFraction.svg + test-data/text.svg + test-data/fonts/varela/OFL.txt + test-data/fonts/varela/VarelaRound-Regular.ttf + test-results/.keep source-repository head type: git @@ -54,14 +74,14 @@ base >=4.7 && <5 , lens ==5.* , linear >=1.21 && <2 - , opencascade-hs >=0.6.2.1 && <0.7 + , opencascade-hs >=0.6.3.0 && <0.7 , optparse-applicative >=0.17 && <0.19 , parsec ==3.1.* , parser-combinators >=1.2 && <1.4 , raw-strings-qq >=1.1 && <2 , svg-tree >=0.6 && <1 - , waterfall-cad >=0.6.2.1 && <0.7 - , waterfall-cad-svg >=0.6.2.1 && <0.7 + , waterfall-cad >=0.6.3.0 && <0.7 + , waterfall-cad-svg >=0.6.3.0 && <0.7 , xml ==1.* default-language: Haskell2010 @@ -76,14 +96,51 @@ base >=4.7 && <5 , lens ==5.* , linear >=1.21 && <2 - , opencascade-hs >=0.6.2.1 && <0.7 + , opencascade-hs >=0.6.3.0 && <0.7 , optparse-applicative >=0.17 && <0.19 , parsec ==3.1.* , parser-combinators >=1.2 && <1.4 , raw-strings-qq >=1.1 && <2 , svg-tree >=0.6 && <1 - , waterfall-cad >=0.6.2.1 && <0.7 + , waterfall-cad >=0.6.3.0 && <0.7 , waterfall-cad-examples - , waterfall-cad-svg >=0.6.2.1 && <0.7 + , waterfall-cad-svg >=0.6.3.0 && <0.7 + , xml ==1.* + default-language: Haskell2010 + +test-suite waterfall-cad-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + DiagramGoldenTests + ExceptionTests + Paths_waterfall_cad_examples + 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: + FontyFruity + , JuicyPixels + , base >=4.7 && <5 + , bytestring + , filepath + , lens ==5.* + , linear >=1.21 && <2 + , mtl + , opencascade-hs >=0.6.3.0 && <0.7 + , optparse-applicative >=0.17 && <0.19 + , parsec ==3.1.* + , parser-combinators >=1.2 && <1.4 + , rasterific-svg + , raw-strings-qq >=1.1 && <2 + , resourcet + , svg-tree >=0.6 && <1 + , tasty + , tasty-golden + , tasty-hunit + , temporary + , waterfall-cad >=0.6.3.0 && <0.7 + , waterfall-cad-examples + , waterfall-cad-svg >=0.6.3.0 && <0.7 , xml ==1.* default-language: Haskell2010