waterfall-cad-svg 0.7.0.0 → 0.8.0.0

raw patch · 6 files changed

+365/−45 lines, 6 filesdep ~opencascade-hsdep ~waterfall-cadPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: opencascade-hs, waterfall-cad

API changes (from Hackage documentation)

Files

• CHANGELOG.md +2/−2
• src/Waterfall/SVG/ToSVG.hs +25/−38
• src/Waterfall/SVG/ToSVG/LineStyle.hs +189/−0
• test/LineStyleTests.hs +134/−0
• test/Main.hs +8/−0
• waterfall-cad-svg.cabal +7/−5

@@ -8,7 +8,7 @@  ## Unreleased -## 0.7.0.0+## 0.8.0.0  ### Added @@ -17,7 +17,7 @@ - Added `Generic` and [`NFData`](https://hackage-content.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData) instances for the following   - `Waterfall.SVG.ToSVG.LineStyle`   - `Waterfall.SVG.FromSVG.SVGError`-  - `Waterfall.SVG.FromSVG.SVGErrorKind`+  - `Waterfall.SVG.FVromSVG.SVGErrorKind`  ### Changed 

@@ -1,12 +1,10 @@ {-# Language OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveGeneric #-} {-| Convert "Waterfall" data into [SVG](https://developer.mozilla.org/en-US/docs/Web/SVG) -} module Waterfall.SVG.ToSVG ( path2DToPathCommands-, LineStyle (..)+, module Waterfall.SVG.ToSVG.LineStyle , lineStyleCss , diagramToSvgWithLineStyle , diagramToSvg@@ -14,6 +12,7 @@ ) where  import qualified Waterfall+import Waterfall.SVG.ToSVG.LineStyle import qualified Graphics.Svg as Svg import qualified Graphics.Svg.CssTypes as Svg.Css import Waterfall.Internal.NearZero (nearZero)@@ -47,7 +46,6 @@ import Control.Applicative ((<|>)) import Control.Arrow ((>>>)) import Control.DeepSeq (NFData (rnf))-import GHC.Generics (Generic)  -- SVG.PathCommand doesn't have an NFData instance -- which is needed for it to be the target of an `unsafeFromAcquire`@@ -200,30 +198,18 @@                     =<< Internal.Finalizers.acquireForeignPtr wire)  --- | How lines should appear--- --- These values are used to generate inline CSS-data LineStyle = LineStyle-    { visibleLineColour :: Waterfall.Colour-    , hiddenLineColour :: Waterfall.Colour-    , hiddenLineOpacity :: Double-    } deriving (Eq, Ord, Show, Generic) -instance NFData LineStyle----defaultLineStyle :: LineStyle-defaultLineStyle = LineStyle-    { visibleLineColour = Waterfall.Colour 0 0 0-    , hiddenLineColour = Waterfall.Colour 0 0 0-    , hiddenLineOpacity = 0.4-    }- -- | The inline CSS used to style an SVG diagram-lineStyleCss :: LineStyle -> [Svg.Css.CssRule]-lineStyleCss (LineStyle {..}) = -    [ Svg.Css.CssRule +lineStyleCss :: DiagramStyle -> [Svg.Css.CssRule]+lineStyleCss style =+    let resolve l fallback line defaultLine = fromMaybe fallback (line ^. l <|> defaultLine ^. l)+        strokeDeclarations line defaultLine =+            [ Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor . colourToPixel $ resolve lineColour (Waterfall.Colour 0 0 0) line defaultLine]]+            , Svg.Css.CssDeclaration "stroke-opacity" [[Svg.Css.CssNumber . Svg.Num $ resolve lineOpacity 1 line defaultLine]]+            , Svg.Css.CssDeclaration "stroke-width" [[Svg.Css.CssNumber . Svg.Num $ resolve lineWidth 1 line defaultLine]]+            ]+    in+    [ Svg.Css.CssRule         [[Svg.Css.AllOf [Svg.Css.OfClass "edge"]]]         [ Svg.Css.CssDeclaration "fill" [[Svg.Css.CssIdent "None"]]         , Svg.Css.CssDeclaration "fill-opacity" [[Svg.Css.CssNumber (Svg.Num 0)]]@@ -231,12 +217,10 @@         ]     , Svg.Css.CssRule         [[Svg.Css.AllOf [Svg.Css.OfClass "visible"], Svg.Css.AllOf[Svg.Css.OfClass "edge"]]]-        [Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor . colourToPixel $ visibleLineColour]]]+        (strokeDeclarations (style ^. diagramVisibleLine) (defaultDiagramStyle ^. diagramVisibleLine))     , Svg.Css.CssRule         [[Svg.Css.AllOf [Svg.Css.OfClass "hidden"], Svg.Css.AllOf [Svg.Css.OfClass "edge"]]]-        [ Svg.Css.CssDeclaration "stroke" [[Svg.Css.CssColor . colourToPixel $ hiddenLineColour]]-        , Svg.Css.CssDeclaration "stroke-opacity" [[Svg.Css.CssNumber . Svg.Num $ hiddenLineOpacity]]-        ]+        (strokeDeclarations (style ^. diagramHiddenLine) (defaultDiagramStyle ^. diagramHiddenLine))     , Svg.Css.CssRule         [[Svg.Css.AllOf [Svg.Css.OfClass "fill"]]]         [ Svg.Css.CssDeclaration "fill-rule" [[Svg.Css.CssIdent "evenodd"]]]@@ -248,19 +232,22 @@ -- and are grouped within elements with class "sharp"\/"outline" and "visible"\/"hidden" --  -- The diagram fills have the class "fill"-diagramToSvgWithLineStyle :: LineStyle -> Waterfall.Diagram -> Svg.Document+diagramToSvgWithLineStyle :: DiagramStyle -> Waterfall.Diagram -> Svg.Document diagramToSvgWithLineStyle lineStyle diagram =      case Waterfall.diagramBoundingBox diagram of          Nothing -> Svg.Document Nothing Nothing Nothing [] mempty mempty mempty mempty         Just (lo, hi) -> -            let w = Just . Svg.Num $ (hi - lo) ^. _x + 4-                h = Just . Svg.Num $ (hi - lo) ^. _y + 4-                d' = Waterfall.translate2D (2 + negate lo) diagram+            let +                w' = (hi - lo) ^. _x + 4+                h' = (hi - lo) ^. _y + 4           +                w = Just . Svg.Num $ w'+                h = Just . Svg.Num $ h'+                viewbox = Just (lo ^. _x - 2, lo ^. _y - 2, w', h')                 paths lt visibility =                     path2DToPathCommands =<<-                        Waterfall.diagramLines lt visibility d'+                        Waterfall.diagramLines lt visibility diagram                 styles = lineStyleCss lineStyle-                document e = Svg.Document Nothing w h [e] mempty mempty styles mempty+                document e = Svg.Document viewbox w h [e] mempty mempty styles mempty                 pathOf lt visibility =                          Svg.defaultSvg                              & Svg.pathDefinition .~ paths lt visibility@@ -270,7 +257,7 @@                 fills =                      Svg.defaultSvg                          & Svg.groupChildren .~ -                            (Waterfall.getDiagramFills d' +                            (Waterfall.getDiagramFills diagram                                 <&> (fillToPath                                     >>> Svg.drawAttr . Svg.attrClass .~ ["fill"]                                     >>> Svg.PathTree@@ -303,7 +290,7 @@ --  -- The diagram fills have the class "fill" diagramToSvg :: Waterfall.Diagram -> Svg.Document-diagramToSvg = diagramToSvgWithLineStyle defaultLineStyle+diagramToSvg = diagramToSvgWithLineStyle defaultDiagramStyle  -- | Write a `Waterfall.Diagram`, to an SVG file at the specified location  writeDiagramSVG :: FilePath -> Waterfall.Diagram -> IO ()

@@ -0,0 +1,189 @@+{-|+Module: Waterfall.SVG.ToSVG.LineStyle++Specify how the `Waterfall.Path2D`s in a `Waterfall.Diagram.Diagram` are displayed when it's converted to SVG (see `Waterfall.SVG.ToSVG.diagramToSvgWithLineStyle`).++`DiagramStyle` values can be constructed from the @lineWith*@ and @diagramWith*@ functions and can be combined monoidally (with `<>`), e.g.++@+thickVisibleThinHiddenLines =+    diagramWithVisibleLine +        ( lineWithColour (Colour 0 0 0) +            <> lineWithOpacity 1.0+            <> lineWithWidth 3.0+        ) +    <> diagramWithHiddenLine+        ( lineWithColour (Colour 0.3 0.3 1.0) +            <> lineWithOpacity 0.2+            <> lineWithWidth 0.5+        )+@++Properties that are not set fall back to the values in `defaultDiagramStyle`+-}++{-# LANGUAGE DeriveGeneric, DerivingVia, InstanceSigs #-}+module Waterfall.SVG.ToSVG.LineStyle+( DiagramStyle+, LineStyle+, defaultDiagramStyle+-- * Constructors+, lineWithColour+, lineWithOpacity+, lineWithWidth+, diagramWithVisibleLine+, diagramWithHiddenLine+-- * Optics+, lineColour+, lineOpacity+, lineWidth+, diagramVisibleLine+, diagramHiddenLine+) where++import qualified Waterfall+import GHC.Generics (Generic, Generically (..))+import Control.DeepSeq (NFData)+import Data.Monoid (Last (..), Endo (..))+import Data.Maybe (catMaybes)+import Data.List (intersperse)+import Control.Lens (Lens', lens)++-- | How the lines in a diagram should appear+--+-- `DiagramStyle` values can be constructed from the @diagramWith*@ functions and can be combined monoidally (with `<>`).+data DiagramStyle = DiagramStyle+    { _visibleLine :: LineStyle+    , _hiddenLine :: LineStyle+    } deriving (Eq, Ord, Generic)+    deriving (Semigroup, Monoid) via (Generically DiagramStyle)++instance NFData DiagramStyle++instance Show DiagramStyle where +  showsPrec :: Int -> DiagramStyle -> ShowS+  showsPrec d p = +    let showTerm name term =+            showString name+            . showChar ' '+            . showsPrec 11 term+        showVisible = showTerm "diagramWithVisibleLine" (_visibleLine p)+        showHidden = showTerm "diagramWithHiddenLine" (_hiddenLine p)+    in case (_visibleLine p == mempty, _hiddenLine p == mempty) of+        (True, True) -> showString "mempty"+        (True, False) -> showParen (d > 10) showHidden+        (False, True) -> showParen (d > 10) showVisible+        (False, False) ->+            showParen (d > 6)+            ( showVisible+              . showString " <> "+              . showHidden+            )++-- | How a particular set of lines (visible or hidden) should appear+--+-- `LineStyle` values can be constructed from the @lineWith*@ functions and can be combined monoidally (with `<>`).+data LineStyle = LineStyle+    { _lineColour :: Last Waterfall.Colour+    , _lineOpacity :: Last Double+    , _lineWidth :: Last Double+    } deriving (Eq, Ord, Generic)+    deriving (Semigroup, Monoid) via (Generically LineStyle)++instance NFData LineStyle++instance Show LineStyle where+  showsPrec :: Int -> LineStyle -> ShowS+  showsPrec d p = +    let term name field = +            let fv v = +                    showString name+                     . showChar ' '+                     . showsPrec 11 v +            in fv <$> getLast (field p)+        terms = catMaybes +            [ term "lineWithColour" _lineColour+            , term "lineWithOpacity" _lineOpacity+            , term "lineWithWidth" _lineWidth+            ]+    in case terms of+        [] -> showString "mempty"+        _ -> showParen (d > 6) . appEndo+            . foldMap Endo+            . intersperse (showString " <> ") +            $ terms++-- | Create a `LineStyle` with a given `Waterfall.Colour`+lineWithColour :: Waterfall.Colour -> LineStyle+lineWithColour c = mempty {_lineColour = Last . Just $ c}++-- | The `Waterfall.Colour` used to draw a set of lines+--+-- Used to set the @stroke@ CSS property+lineColour :: Lens' LineStyle (Maybe Waterfall.Colour)+lineColour = lens+    (getLast . _lineColour)+    (\ls c -> ls {_lineColour = Last c})++-- | Create a `LineStyle` with a given opacity+--+-- Opacity is in the range [0, 1]+lineWithOpacity :: Double -> LineStyle+lineWithOpacity opacity = mempty {_lineOpacity = Last . Just $ opacity}++-- | The opacity used to draw a set of lines+--+-- Used to set the @stroke-opacity@ CSS property+lineOpacity :: Lens' LineStyle (Maybe Double)+lineOpacity = lens+    (getLast . _lineOpacity)+    (\ls c -> ls {_lineOpacity = Last c})++-- | Create a `LineStyle` with a given width+--+-- Width is in SVG user units+lineWithWidth :: Double -> LineStyle+lineWithWidth width = mempty {_lineWidth= Last . Just $ width}++-- | The width used to draw a set of lines+--+-- Used to set the @stroke-width@ CSS property+lineWidth :: Lens' LineStyle (Maybe Double)+lineWidth = lens+    (getLast . _lineWidth)+    (\ls c -> ls {_lineWidth = Last c})++-- | Create a `DiagramStyle` specifying how to draw visible lines+diagramWithVisibleLine :: LineStyle -> DiagramStyle+diagramWithVisibleLine lineStyle = mempty {_visibleLine = lineStyle}++-- | The visible line style for a `DiagramStyle`+diagramVisibleLine :: Lens' DiagramStyle LineStyle+diagramVisibleLine = lens _visibleLine (\ds ls -> ds {_visibleLine = ls})++-- | Create a `DiagramStyle` specifying how to draw hidden lines+diagramWithHiddenLine :: LineStyle -> DiagramStyle+diagramWithHiddenLine lineStyle = mempty {_hiddenLine = lineStyle}++-- | The hidden line style for a `DiagramStyle`+diagramHiddenLine :: Lens' DiagramStyle LineStyle+diagramHiddenLine = lens _hiddenLine (\ds ls -> ds {_hiddenLine = ls})++-- | Fallback values used for a property of a `DiagramStyle` which is unset+--+-- @+-- defaultDiagramStyle /= mempty+-- @+defaultDiagramStyle :: DiagramStyle+defaultDiagramStyle = DiagramStyle+    { _visibleLine = LineStyle +        { _lineColour = Last . Just $ Waterfall.Colour 0 0 0+        , _lineOpacity = Last . Just $ 1+        , _lineWidth = Last . Just $ 1+        }+    , _hiddenLine = LineStyle +        { _lineColour = Last . Just $ Waterfall.Colour 0 0 0+        , _lineOpacity = Last . Just $ 0.4+        , _lineWidth = Last . Just $ 1+        }+    }

@@ -0,0 +1,134 @@+module LineStyleTests+( lineStyleTests+) where++import Waterfall.SVG.ToSVG.LineStyle+import Waterfall.Colour (Colour (..))+import Control.Lens ((^.))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit++lineStyleTests :: TestTree+lineStyleTests = testGroup "LineStyle"+    [ lineStyleShowTests+    , diagramStyleShowTests+    , lensTests+    ]++lineStyleShowTests :: TestTree+lineStyleShowTests = testGroup "LineStyle Show instance"+    [ testCase "mempty" $+        assertEqual "" "mempty" (show (mempty :: LineStyle))++    , testCase "single property" $+        assertEqual ""+            "lineWithColour (Colour 1.0 0.0 0.0)"+            (show (lineWithColour (Colour 1 0 0)))++    , testCase "combined properties" $+        assertEqual ""+            "lineWithColour (Colour 0.0 0.0 1.0) <> lineWithOpacity 0.5"+            (show+                (lineWithOpacity 0.5+                <> lineWithColour (Colour 1 0 0)+                <> lineWithColour (Colour 0 0 1)+                ))++    , testCase "all properties" $+        assertEqual ""+            "lineWithColour (Colour 1.0 0.0 0.0) <> lineWithOpacity 0.5 <> lineWithWidth 2.0"+            (show+                (lineWithWidth 2+                <> lineWithOpacity 0.5+                <> lineWithColour (Colour 1 0 0)+                ))++    , testCase "negative argument in brackets" $+        assertEqual ""+            "lineWithWidth (-1.0)"+            (show (lineWithWidth (-1)))++    , testCase "single property in brackets when used as an argument" $+        assertEqual ""+            "Just (lineWithWidth 2.0)"+            (show (Just (lineWithWidth 2)))++    , testCase "combined properties in brackets when used as an argument" $+        assertEqual ""+            "Just (lineWithOpacity (-0.5) <> lineWithWidth 2.0)"+            (show (Just (lineWithOpacity (-0.5) <> lineWithWidth 2)))+    ]++diagramStyleShowTests :: TestTree+diagramStyleShowTests = testGroup "DiagramStyle Show instance"+    [ testCase "mempty" $+        assertEqual "" "mempty" (show (mempty :: DiagramStyle))++    , testCase "visible line only" $+        assertEqual ""+            "diagramWithVisibleLine (lineWithWidth 2.0)"+            (show (diagramWithVisibleLine (lineWithWidth 2)))++    , testCase "hidden line only, with combined properties" $+        assertEqual ""+            "diagramWithHiddenLine (lineWithColour (Colour 0.0 0.0 0.0) <> lineWithOpacity 0.4)"+            (show (diagramWithHiddenLine (lineWithColour (Colour 0 0 0) <> lineWithOpacity 0.4)))++    , testCase "both lines" $+        assertEqual ""+            "diagramWithVisibleLine (lineWithWidth 2.0) <> diagramWithHiddenLine (lineWithOpacity 0.4)"+            (show+                (diagramWithHiddenLine (lineWithOpacity 0.4)+                <> diagramWithVisibleLine (lineWithWidth 2)+                ))++    , testCase "repeated lines are merged" $+        assertEqual ""+            "diagramWithVisibleLine (lineWithColour (Colour 1.0 0.0 0.0) <> lineWithWidth 2.0) <> diagramWithHiddenLine (lineWithOpacity 0.4)"+            (show+                (diagramWithVisibleLine (lineWithWidth 2)+                <> diagramWithHiddenLine (lineWithOpacity 0.4)+                <> diagramWithVisibleLine (lineWithColour (Colour 1 0 0))+                ))++    , testCase "visible line only in brackets when used as an argument" $+        assertEqual ""+            "Just (diagramWithVisibleLine (lineWithWidth 2.0))"+            (show (Just (diagramWithVisibleLine (lineWithWidth 2))))++    , testCase "both lines in brackets when used as an argument" $+        assertEqual ""+            "Just (diagramWithVisibleLine (lineWithWidth 2.0) <> diagramWithHiddenLine (lineWithOpacity 0.4))"+            (show+                (Just+                    (diagramWithVisibleLine (lineWithWidth 2)+                    <> diagramWithHiddenLine (lineWithOpacity 0.4)+                    )))++    , testCase "defaultStyle" $+        assertEqual ""+            "diagramWithVisibleLine (lineWithColour (Colour 0.0 0.0 0.0) <> lineWithOpacity 1.0 <> lineWithWidth 1.0) <> diagramWithHiddenLine (lineWithColour (Colour 0.0 0.0 0.0) <> lineWithOpacity 0.4 <> lineWithWidth 1.0)"+            (show defaultDiagramStyle)+    ]++lensTests :: TestTree+lensTests = testGroup "lenses"+    [ testCase "lineColour" $+        assertEqual "" (Just (Colour 1 0 0)) (lineWithColour (Colour 1 0 0) ^. lineColour)++    , testCase "lineOpacity" $+        assertEqual "" (Just 0.5) (lineWithOpacity 0.5 ^. lineOpacity)++    , testCase "lineWidth" $+        assertEqual "" (Just 2) (lineWithWidth 2 ^. lineWidth)++    , testCase "diagramVisibleLine" $+        assertEqual ""+            (lineWithWidth 2)+            (diagramWithVisibleLine (lineWithWidth 2) ^. diagramVisibleLine)++    , testCase "diagramHiddenLine" $+        assertEqual ""+            (lineWithWidth 2)+            (diagramWithHiddenLine (lineWithWidth 2) ^. diagramHiddenLine)+    ]

@@ -6,6 +6,7 @@ import Test.Tasty import Test.Tasty.HUnit import Waterfall.SVG+import LineStyleTests (lineStyleTests)  readTestFile :: FilePath -> IO (Either SVGError ()) readTestFile = fmap void . readSVG <=< getDataFileName@@ -15,6 +16,13 @@  main :: IO () main = defaultMain $+  testGroup "tests"+    [ readSVGTests+    , lineStyleTests+    ]++readSVGTests :: TestTree+readSVGTests =   testGroup "readSVG" $     [ testCase "reads a good file successfully" $ do         result <- readTestFile "test-data/fixture1.svg"

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           waterfall-cad-svg-version:        0.7.0.0+version:        0.8.0.0 synopsis:       Declarative CAD/Solid Modeling Library, SVG Support description:    Please see the README on GitHub at <https://github.com/joe-warren/opencascade-hs#readme> category:       Graphics@@ -34,6 +34,7 @@       Waterfall.SVG       Waterfall.SVG.FromSVG       Waterfall.SVG.ToSVG+      Waterfall.SVG.ToSVG.LineStyle   other-modules:       Paths_waterfall_cad_svg   hs-source-dirs:@@ -46,17 +47,18 @@     , deepseq >=1.4 && <2     , lens ==5.*     , linear >=1.0 && <2-    , opencascade-hs >=0.7.0.0 && <0.8+    , opencascade-hs >=0.8.0.0 && <0.9     , resourcet >=1.2 && <1.4     , svg-tree >=0.6 && <1     , text >=1.2 && <3-    , waterfall-cad >=0.7.0.0 && <0.8+    , waterfall-cad >=0.8.0.0 && <0.9   default-language: Haskell2010  test-suite tests   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      LineStyleTests       Paths_waterfall_cad_svg   hs-source-dirs:       test@@ -68,12 +70,12 @@     , deepseq >=1.4 && <2     , lens ==5.*     , linear >=1.0 && <2-    , opencascade-hs >=0.7.0.0 && <0.8+    , opencascade-hs >=0.8.0.0 && <0.9     , resourcet >=1.2 && <1.4     , svg-tree >=0.6 && <1     , tasty     , tasty-hunit     , text >=1.2 && <3-    , waterfall-cad >=0.7.0.0 && <0.8+    , waterfall-cad >=0.8.0.0 && <0.9     , waterfall-cad-svg   default-language: Haskell2010