From 0088cbdf540dd9a3cf9f87d4f58e4554921fa3ff Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 11:44:17 -0500 Subject: [PATCH 01/11] minor formatting/cleanup --- src/Diagrams/Attributes.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 1f0ec7d7..0a0240fa 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable - , ExistentialQuantification - , GeneralizedNewtypeDeriving - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes @@ -62,7 +61,7 @@ import Diagrams.Core import Data.Colour import Data.Colour.RGBSpace -import Data.Colour.SRGB (sRGBSpace) +import Data.Colour.SRGB (sRGBSpace) import Data.Default.Class @@ -88,7 +87,7 @@ import Data.Semigroup -- both the 'Data.Colour.Colour' and 'Data.Colour.AlphaColour' types -- from the "Data.Colour" library. class Color c where - -- | Convert a color to its standard representation, AlphaColour + -- | Convert a color to its standard representation, AlphaColour. toAlphaColour :: c -> AlphaColour Double -- | An existential wrapper for instances of the 'Color' class. From 9a892281ae87b25c879d98521bbfb0041c9ce3d9 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 11:47:26 -0500 Subject: [PATCH 02/11] add `fromAlphaColour` method to Color class This allows (partial) conversions in both directions, which I found necessary for implementing some lenses to set some color in a given style. Adding such a method seems generally unobjectionable to me. --- src/Diagrams/Attributes.hs | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 0a0240fa..b0ed3b54 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -25,7 +25,7 @@ module Diagrams.Attributes ( -- * Color -- $color - Color(..), SomeColor(..) + Color(..), SomeColor(..), someToAlpha -- ** Line color , LineColor, getLineColor, lineColor, lineColorA, lc, lcA @@ -90,10 +90,18 @@ class Color c where -- | Convert a color to its standard representation, AlphaColour. toAlphaColour :: c -> AlphaColour Double + -- | Convert from an AlphaColour Double. Note that this direction + -- may lose some information. For example, the instance for + -- 'Colour' drops the alpha channel. + fromAlphaColour :: AlphaColour Double -> c + -- | An existential wrapper for instances of the 'Color' class. data SomeColor = forall c. Color c => SomeColor c deriving Typeable +someToAlpha :: SomeColor -> AlphaColour Double +someToAlpha (SomeColor c) = toAlphaColour c + -- | The color with which lines (strokes) are drawn. Note that child -- colors always override parent colors; that is, @'lineColor' c1 -- . 'lineColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@. @@ -166,19 +174,24 @@ fcA :: HasStyle a => AlphaColour Double -> a -> a fcA = fillColor instance (Floating a, Real a) => Color (Colour a) where - toAlphaColour = opaque . colourConvert + toAlphaColour = opaque . colourConvert + fromAlphaColour = colourConvert . (`over` black) instance (Floating a, Real a) => Color (AlphaColour a) where - toAlphaColour = alphaColourConvert + toAlphaColour = alphaColourConvert + fromAlphaColour = alphaColourConvert instance Color SomeColor where toAlphaColour (SomeColor c) = toAlphaColour c + fromAlphaColour c = SomeColor c instance Color LineColor where - toAlphaColour (LineColor (Last c)) = toAlphaColour c + toAlphaColour (LineColor c) = toAlphaColour . getLast $ c + fromAlphaColour = LineColor . Last . fromAlphaColour instance Color FillColor where toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c + fromAlphaColour = FillColor . Commit . Last . fromAlphaColour -- | Convert to an RGB space while preserving the alpha channel. toRGBAUsingSpace :: Color c => RGBSpace Double -> c From a9339c6cfb46e00f4fc58e52ce4b9e8c43166f98 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 11:48:22 -0500 Subject: [PATCH 03/11] D.Attributes: export utility functions mk{Fill,Line}Color These are intentionally not re-exported from the Prelude; most users should not need them. --- src/Diagrams/Attributes.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index b0ed3b54..c188ebb1 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -28,10 +28,10 @@ module Diagrams.Attributes ( Color(..), SomeColor(..), someToAlpha -- ** Line color - , LineColor, getLineColor, lineColor, lineColorA, lc, lcA + , LineColor, getLineColor, mkLineColor, lineColor, lineColorA, lc, lcA -- ** Fill color - , FillColor, getFillColor, recommendFillColor, fillColor, fc, fcA + , FillColor, getFillColor, mkFillColor, recommendFillColor, fillColor, fc, fcA -- ** Opacity , Opacity, getOpacity, opacity @@ -117,13 +117,16 @@ instance Default LineColor where getLineColor :: LineColor -> SomeColor getLineColor (LineColor (Last c)) = c +mkLineColor :: Color c => c -> LineColor +mkLineColor = LineColor . Last . SomeColor + -- | Set the line (stroke) color. This function is polymorphic in the -- color type (so it can be used with either 'Colour' or -- 'AlphaColour'), but this can sometimes create problems for type -- inference, so the 'lc' and 'lcA' variants are provided with more -- concrete types. lineColor :: (Color c, HasStyle a) => c -> a -> a -lineColor = applyAttr . LineColor . Last . SomeColor +lineColor = applyAttr . mkLineColor -- | Apply a 'lineColor' attribute. lineColorA :: HasStyle a => LineColor -> a -> a @@ -148,12 +151,15 @@ newtype FillColor = FillColor (Recommend (Last SomeColor)) deriving (Typeable, Semigroup) instance AttributeClass FillColor +mkFillColor :: Color c => c -> FillColor +mkFillColor = FillColor . Commit . Last . SomeColor + -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), -- but this can sometimes create problems for type inference, so the -- 'fc' and 'fcA' variants are provided with more concrete types. fillColor :: (Color c, HasStyle a) => c -> a -> a -fillColor = applyAttr . FillColor . Commit . Last . SomeColor +fillColor = applyAttr . mkFillColor -- | Set a \"recommended\" fill color, to be used only if no explicit -- calls to 'fillColor' (or 'fc', or 'fcA') are used. From 493721594efb41753fe4d351618a5f8132777019 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 12:04:55 -0500 Subject: [PATCH 04/11] D.TwoD.Arrow: Lenses for setting head, tail, and shaft style directly. This is the sort of convenient thing that we can do now that we use lens for everything: we can provide headColor, tailColor, and shaftColor directly as "virtual fields" so the user doesn't have to think about style modification functions in the common case where they just want to set the color (and we also protect them from the easy mistake of setting the line color on the head, or fill color on the shaft). This is something of a proof-of-concept. Ideally we could even refactor these as e.g. headColor = headStyle . styleFillColor where styleFillColor :: (Color c, Color c') => Setter (Style v) (Style v) c c'. --- src/Diagrams/TwoD.hs | 3 +++ src/Diagrams/TwoD/Arrow.hs | 43 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 44 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index a9dbc3ee..bee21b80 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -152,8 +152,11 @@ module Diagrams.TwoD , tailSize , headGap , tailGap + , headColor , headStyle + , tailColor , tailStyle + , shaftColor , shaftStyle -- * Text diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index b9037c18..70163510 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -76,8 +76,11 @@ module Diagrams.TwoD.Arrow , tailSize , headGap , tailGap + , headColor , headStyle + , tailColor , tailStyle + , shaftColor , shaftStyle -- | See "Diagrams.TwoD.Arrowheads" for a list of standard @@ -86,9 +89,10 @@ module Diagrams.TwoD.Arrow ) where import Control.Arrow (first) -import Control.Lens (Lens', generateSignatures, +import Control.Lens (Lens', Setter, + generateSignatures, lensRules, makeLensesWith, - (%~), (&), (.~), (^.)) + sets, (%~), (&), (.~), (^.)) import Data.AffineSpace import Data.Default.Class import Data.Functor ((<$>)) @@ -102,6 +106,7 @@ import Data.VectorSpace import Data.Colour hiding (atop) import Diagrams.Attributes import Diagrams.Core +import Diagrams.Core.Style (setAttr) import Diagrams.Core.Types (QDiaLeaf (..), mkQD') import Diagrams.Parametric @@ -188,6 +193,40 @@ tailStyle :: Lens' ArrowOpts (Style R2) -- | Style to apply to the shaft. See `headStyle`. shaftStyle :: Lens' ArrowOpts (Style R2) +-- | A lens for setting or modifying the color of an arrowhead. For +-- example, one may write @... (with & headColor .~ blue)@ to get an +-- arrow with a blue head, or @... (with & headColor %~ +-- (\`withOpacity\` 0.5))@ to make an arrow's head 50\% transparent. +-- For more general control over the style of arrowheads, see +-- 'headStyle'. +headColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' +headColor = sets modifyHeadColor + where + modifyHeadColor f opts@(ArrowOpts { _headStyle = sty }) = + let c = fromMaybe (fromAlphaColour (opaque black)) + (fromAlphaColour . someToAlpha . getFillColor <$> getAttr sty) + in opts & headStyle %~ setAttr (mkFillColor (f c)) + +-- | A lens for setting or modifying the color of an arrow +-- tail. See 'headColor'. +tailColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' +tailColor = sets modifyTailColor + where + modifyTailColor f opts@(ArrowOpts { _tailStyle = sty }) = + let c = fromMaybe (fromAlphaColour (opaque black)) + (fromAlphaColour . someToAlpha . getFillColor <$> getAttr sty) + in opts & tailStyle %~ setAttr (mkFillColor (f c)) + +-- | A lens for setting or modifying the color of an arrow +-- shaft. See 'headColor'. +shaftColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' +shaftColor = sets modifyShaftColor + where + modifyShaftColor f opts@(ArrowOpts { _shaftStyle = sty }) = + let c = fromMaybe (fromAlphaColour (opaque black)) + (fromAlphaColour . someToAlpha . getLineColor <$> getAttr sty) + in opts & shaftStyle %~ setAttr (mkLineColor (f c)) + -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. -- The semigroup stucture of the lw attribute will insure that the default From f358e80f10a00630eba1379672c6f259fb3234f9 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 12:22:15 -0500 Subject: [PATCH 05/11] Default instance for FillColor Not sure why we were missing this before. --- src/Diagrams/Attributes.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index c188ebb1..154f4a8a 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -151,6 +151,9 @@ newtype FillColor = FillColor (Recommend (Last SomeColor)) deriving (Typeable, Semigroup) instance AttributeClass FillColor +instance Default FillColor where + def = FillColor (Recommend (Last (SomeColor (transparent :: AlphaColour Double)))) + mkFillColor :: Color c => c -> FillColor mkFillColor = FillColor . Commit . Last . SomeColor From acc2f7a9cd96f2944d60e5466495132ae196e415 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 12:23:50 -0500 Subject: [PATCH 06/11] D.Attributes: Setters for Style -> {line,fill} color Note these can't be lenses because there's nothing to return if the style does not contain a line or fill color attribute. (One could just return a default value but that would violate the lens laws.) Seems to work pretty well! Perhaps we should add setters for other attributes as well. --- src/Diagrams/Attributes.hs | 40 ++++++++++++++++++++++++++++++-------- 1 file changed, 32 insertions(+), 8 deletions(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 154f4a8a..58c5fe2b 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -28,10 +28,10 @@ module Diagrams.Attributes ( Color(..), SomeColor(..), someToAlpha -- ** Line color - , LineColor, getLineColor, mkLineColor, lineColor, lineColorA, lc, lcA + , LineColor, getLineColor, mkLineColor, styleLineColor, lineColor, lineColorA, lc, lcA -- ** Fill color - , FillColor, getFillColor, mkFillColor, recommendFillColor, fillColor, fc, fcA + , FillColor, getFillColor, mkFillColor, styleFillColor, recommendFillColor, fillColor, fc, fcA -- ** Opacity , Opacity, getOpacity, opacity @@ -57,18 +57,18 @@ module Diagrams.Attributes ( ) where -import Diagrams.Core - +import Control.Lens (Setter, sets) import Data.Colour import Data.Colour.RGBSpace import Data.Colour.SRGB (sRGBSpace) - import Data.Default.Class - -import Data.Typeable - +import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup +import Data.Typeable + +import Diagrams.Core +import Diagrams.Core.Style (setAttr) ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -120,6 +120,18 @@ getLineColor (LineColor (Last c)) = c mkLineColor :: Color c => c -> LineColor mkLineColor = LineColor . Last . SomeColor +styleLineColor :: (Color c, Color c') => Setter (Style v) (Style v) c c' +styleLineColor = sets modifyLineColor + where + modifyLineColor f s + = flip setAttr s + . mkFillColor + . f + . fromAlphaColour . someToAlpha + . getLineColor + . fromMaybe def . getAttr + $ s + -- | Set the line (stroke) color. This function is polymorphic in the -- color type (so it can be used with either 'Colour' or -- 'AlphaColour'), but this can sometimes create problems for type @@ -157,6 +169,18 @@ instance Default FillColor where mkFillColor :: Color c => c -> FillColor mkFillColor = FillColor . Commit . Last . SomeColor +styleFillColor :: (Color c, Color c') => Setter (Style v) (Style v) c c' +styleFillColor = sets modifyFillColor + where + modifyFillColor f s + = flip setAttr s + . mkFillColor + . f + . fromAlphaColour . someToAlpha + . getFillColor + . fromMaybe def . getAttr + $ s + -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), -- but this can sometimes create problems for type inference, so the From 78496017fe220d8960a3be680ace9652ceb222d2 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 12:24:23 -0500 Subject: [PATCH 07/11] D.TwoD.Arrow: reimplement {head,tail,shaft}Color lenses in terms of style{Line,Fill}Color --- src/Diagrams/TwoD/Arrow.hs | 24 ++++-------------------- 1 file changed, 4 insertions(+), 20 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 70163510..ea91f3f6 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -92,7 +92,7 @@ import Control.Arrow (first) import Control.Lens (Lens', Setter, generateSignatures, lensRules, makeLensesWith, - sets, (%~), (&), (.~), (^.)) + (%~), (&), (.~), (^.)) import Data.AffineSpace import Data.Default.Class import Data.Functor ((<$>)) @@ -106,7 +106,6 @@ import Data.VectorSpace import Data.Colour hiding (atop) import Diagrams.Attributes import Diagrams.Core -import Diagrams.Core.Style (setAttr) import Diagrams.Core.Types (QDiaLeaf (..), mkQD') import Diagrams.Parametric @@ -200,32 +199,17 @@ shaftStyle :: Lens' ArrowOpts (Style R2) -- For more general control over the style of arrowheads, see -- 'headStyle'. headColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' -headColor = sets modifyHeadColor - where - modifyHeadColor f opts@(ArrowOpts { _headStyle = sty }) = - let c = fromMaybe (fromAlphaColour (opaque black)) - (fromAlphaColour . someToAlpha . getFillColor <$> getAttr sty) - in opts & headStyle %~ setAttr (mkFillColor (f c)) +headColor = headStyle . styleFillColor -- | A lens for setting or modifying the color of an arrow -- tail. See 'headColor'. tailColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' -tailColor = sets modifyTailColor - where - modifyTailColor f opts@(ArrowOpts { _tailStyle = sty }) = - let c = fromMaybe (fromAlphaColour (opaque black)) - (fromAlphaColour . someToAlpha . getFillColor <$> getAttr sty) - in opts & tailStyle %~ setAttr (mkFillColor (f c)) +tailColor = tailStyle . styleFillColor -- | A lens for setting or modifying the color of an arrow -- shaft. See 'headColor'. shaftColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' -shaftColor = sets modifyShaftColor - where - modifyShaftColor f opts@(ArrowOpts { _shaftStyle = sty }) = - let c = fromMaybe (fromAlphaColour (opaque black)) - (fromAlphaColour . someToAlpha . getLineColor <$> getAttr sty) - in opts & shaftStyle %~ setAttr (mkLineColor (f c)) +shaftColor = shaftStyle . styleLineColor -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. From 17dc7f061d654b503ed70013f8e29c877954fe57 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 12:34:32 -0500 Subject: [PATCH 08/11] D.TwoD.Arrow: bug fix: styleLineColor should set line color, not fill color --- src/Diagrams/Attributes.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 58c5fe2b..ef4729b1 100644 --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -125,7 +125,7 @@ styleLineColor = sets modifyLineColor where modifyLineColor f s = flip setAttr s - . mkFillColor + . mkLineColor . f . fromAlphaColour . someToAlpha . getLineColor From c9a36a95f8c3b82224ac6c2d2e27dcdedc09c89c Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 12:43:31 -0500 Subject: [PATCH 09/11] make {head,tail,Shaft}Color less polymorphic The more polymorphic versions caused problems for type inference in typical use cases. --- src/Diagrams/TwoD/Arrow.hs | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index ea91f3f6..f7f4cc51 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -89,7 +89,7 @@ module Diagrams.TwoD.Arrow ) where import Control.Arrow (first) -import Control.Lens (Lens', Setter, +import Control.Lens (Lens', Setter', generateSignatures, lensRules, makeLensesWith, (%~), (&), (.~), (^.)) @@ -193,22 +193,32 @@ tailStyle :: Lens' ArrowOpts (Style R2) shaftStyle :: Lens' ArrowOpts (Style R2) -- | A lens for setting or modifying the color of an arrowhead. For --- example, one may write @... (with & headColor .~ blue)@ to get an --- arrow with a blue head, or @... (with & headColor %~ --- (\`withOpacity\` 0.5))@ to make an arrow's head 50\% transparent. --- For more general control over the style of arrowheads, see --- 'headStyle'. -headColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' +-- example, one may write @... (with & headColor .~ blue)@ to get an +-- arrow with a blue head, or @... (with & headColor %~ blend 0.5 +-- white)@ to make an arrow's head a lighter color. For more general +-- control over the style of arrowheads, see 'headStyle'. +-- +-- Note that the most general type of @headColor@ would be +-- +-- > (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' +-- +-- but that can cause problems for type inference when setting the +-- color. However, using it at that more general type may +-- occasionally be useful, for example, if you want to apply some +-- opacity to a color, as in @... (with & headColor %~ +-- (\`withOpacity\` 0.5))@. If you want the more general type, you +-- can use @'headStyle' . 'styleFillColor'@ in place of @headColor@. +headColor :: Color c => Setter' ArrowOpts c headColor = headStyle . styleFillColor -- | A lens for setting or modifying the color of an arrow -- tail. See 'headColor'. -tailColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' +tailColor :: Color c => Setter' ArrowOpts c tailColor = tailStyle . styleFillColor -- | A lens for setting or modifying the color of an arrow -- shaft. See 'headColor'. -shaftColor :: (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' +shaftColor :: Color c => Setter' ArrowOpts c shaftColor = shaftStyle . styleLineColor -- Set the default shaft style of an `ArrowOpts` record by applying the From 7248762ce5db8c922bbb1bb133c8e47d86fdb79a Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 13:54:17 -0500 Subject: [PATCH 10/11] D.TwoD.Arrow: minor Haddock improvements --- src/Diagrams/TwoD/Arrow.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index f7f4cc51..f2890e4b 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -19,7 +19,7 @@ module Diagrams.TwoD.Arrow - ( -- * Examples: + ( -- * Examples -- ** Example 1 -- | <> -- @@ -53,7 +53,7 @@ module Diagrams.TwoD.Arrow -- > -- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 - -- * Documentation + -- * Creating arrows arrow , arrow' , arrowAt @@ -67,6 +67,8 @@ module Diagrams.TwoD.Arrow , connectOutside , connectOutside' , straightShaft + + -- * Options , ArrowOpts(..) , arrowHead From 35e582848c0416624df331e45d620aeca1d89d55 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 14 Nov 2013 13:56:03 -0500 Subject: [PATCH 11/11] D.TwoD.Arrow: remove default shaft width The shaft width will now be taken from the ambient line width attribute by default. Explicitly setting the line width via the shaftStyle will always override this default. --- src/Diagrams/TwoD/Arrow.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index f2890e4b..700cb609 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -141,9 +141,6 @@ data ArrowOpts straightShaft :: Trail R2 straightShaft = trailFromOffsets [unitX] -defShaftWidth :: Double -defShaftWidth = 0.03 - instance Default ArrowOpts where def = ArrowOpts { _arrowHead = dart @@ -228,7 +225,7 @@ shaftColor = shaftStyle . styleLineColor -- The semigroup stucture of the lw attribute will insure that the default -- is only used if it has not been set in @opts@. shaftSty :: ArrowOpts -> Style R2 -shaftSty opts = lw defShaftWidth (opts^.shaftStyle) +shaftSty opts = opts^.shaftStyle -- Set the default head style. See `shaftSty`. headSty :: ArrowOpts -> Style R2 @@ -260,7 +257,7 @@ widthOfJoint :: Style v -> Double widthOfJoint sStyle = let w = fmap getLineWidth . getAttr $ sStyle in case w of - Nothing -> defShaftWidth -- this case should never happen. + Nothing -> 0.01 -- this case should never happen. Just w' -> w' -- | Combine the head and its joint into a single scale invariant diagram