diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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 @@ -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 () diff --git a/src/Waterfall/SVG/ToSVG/LineStyle.hs b/src/Waterfall/SVG/ToSVG/LineStyle.hs new file mode 100644 --- /dev/null +++ b/src/Waterfall/SVG/ToSVG/LineStyle.hs @@ -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 + } + } diff --git a/test/LineStyleTests.hs b/test/LineStyleTests.hs new file mode 100644 --- /dev/null +++ b/test/LineStyleTests.hs @@ -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) + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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" diff --git a/waterfall-cad-svg.cabal b/waterfall-cad-svg.cabal --- a/waterfall-cad-svg.cabal +++ b/waterfall-cad-svg.cabal @@ -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 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