Lenses for setting arrow head, tail, and shaft colors

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

src/Diagrams/TwoD.hs

@@ -152,8 +152,11 @@ module Diagrams.TwoD
        , tailSize
        , headGap
        , tailGap
+       , headColor
        , headStyle
+       , tailColor
        , tailStyle
+       , shaftColor
        , shaftStyle
 
          -- * Text

src/Diagrams/TwoD/Arrow.hs

@@ -19,7 +19,7 @@
 
 
 module Diagrams.TwoD.Arrow
-       ( -- * Examples:
+       ( -- * Examples
          -- ** Example 1
 -- | <<diagrams/src_Diagrams_TwoD_Arrow_example1.svg#diagram=example1&width=500>>
 --
@@ -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