diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index 1f0ec7d7..ef4729b1 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 @@ -26,13 +25,13 @@ module Diagrams.Attributes ( -- * Color -- $color - Color(..), SomeColor(..) + Color(..), SomeColor(..), someToAlpha -- ** Line color - , LineColor, getLineColor, lineColor, lineColorA, lc, lcA + , LineColor, getLineColor, mkLineColor, styleLineColor, lineColor, lineColorA, lc, lcA -- ** Fill color - , FillColor, getFillColor, recommendFillColor, fillColor, fc, fcA + , FillColor, getFillColor, mkFillColor, styleFillColor, recommendFillColor, fillColor, fc, fcA -- ** Opacity , Opacity, getOpacity, opacity @@ -58,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.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 ------------------------------------------------- @@ -88,13 +87,21 @@ 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 + -- | 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@. @@ -110,13 +117,28 @@ instance Default LineColor where getLineColor :: LineColor -> SomeColor 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 + . mkLineColor + . 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 -- 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 @@ -141,12 +163,30 @@ 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 + +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 -- '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. @@ -167,19 +207,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 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..700cb609 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 @@ -76,8 +78,11 @@ module Diagrams.TwoD.Arrow , tailSize , headGap , tailGap + , headColor , headStyle + , tailColor , tailStyle + , shaftColor , shaftStyle -- | See "Diagrams.TwoD.Arrowheads" for a list of standard @@ -86,7 +91,8 @@ module Diagrams.TwoD.Arrow ) where import Control.Arrow (first) -import Control.Lens (Lens', generateSignatures, +import Control.Lens (Lens', Setter', + generateSignatures, lensRules, makeLensesWith, (%~), (&), (.~), (^.)) import Data.AffineSpace @@ -135,9 +141,6 @@ data ArrowOpts straightShaft :: Trail R2 straightShaft = trailFromOffsets [unitX] -defShaftWidth :: Double -defShaftWidth = 0.03 - instance Default ArrowOpts where def = ArrowOpts { _arrowHead = dart @@ -188,12 +191,41 @@ 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 %~ 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 => Setter' ArrowOpts c +tailColor = tailStyle . styleFillColor + +-- | A lens for setting or modifying the color of an arrow +-- shaft. See 'headColor'. +shaftColor :: Color c => Setter' ArrowOpts 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. -- 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 @@ -225,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