From 493721594efb41753fe4d351618a5f8132777019 Mon Sep 17 00:00:00 2001
From: Brent Yorgey <byorgey@cis.upenn.edu>
Date: Thu, 14 Nov 2013 12:04:55 -0500
Subject: [PATCH] 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