add styleFillTexture, styleLineTexture

src/Diagrams/TwoD.hs

@@ -148,10 +148,13 @@ module Diagrams.TwoD
        , tailGap
        , gaps, gap
        , headColor
+       , headTexture
        , headStyle
        , tailColor
+       , tailTexture
        , tailStyle
        , shaftColor
+       , shaftTexture
        , shaftStyle
        , headSize
        , tailSize

src/Diagrams/TwoD/Arrow.hs

@@ -81,12 +81,15 @@ module Diagrams.TwoD.Arrow
        , tailGap
        , gaps, gap
        , headColor
+       , headTexture
        , headStyle
        , headSize
        , tailColor
+       , tailTexture
        , tailStyle
        , tailSize
        , shaftColor
+       , shaftTexture
        , shaftStyle
        , straightShaft
 
@@ -235,6 +238,21 @@ tailColor = tailStyle . styleFillColor
 shaftColor :: Color c => Setter' ArrowOpts c
 shaftColor = shaftStyle . styleLineColor
 
+-- | A lens for setting or modifying the texture of an arrow
+--   head.
+headTexture :: Setter' ArrowOpts Texture
+headTexture = headStyle . styleFillTexture
+
+-- | A lens for setting or modifying the texture of an arrow
+--   tail.
+tailTexture :: Setter' ArrowOpts Texture
+tailTexture = tailStyle . styleFillTexture
+
+-- | A lens for setting or modifying the texture of an arrow
+--   shaft.
+shaftTexture :: Setter' ArrowOpts Texture
+shaftTexture = shaftStyle . styleLineTexture
+
 -- 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

src/Diagrams/TwoD/Attributes.hs

@@ -50,13 +50,15 @@ module Diagrams.TwoD.Attributes (
 
   -- ** Line texture
   ,  LineTexture(..), getLineTexture, lineTexture, lineTextureA
+  ,  mkLineTexture, styleLineTexture
 
   -- ** Line color
   , LineColor, lineColor, getLineColor, lc, lcA, lineColorA
   , mkLineColor, styleLineColor
 
   -- ** Fill texture
   , FillTexture(..), getFillTexture, fillTexture
+  , mkFillTexture, styleFillTexture
 
   -- ** Fill color
   , FillColor, fillColor, getFillColor, fc, fcA, recommendFillColor
@@ -381,6 +383,20 @@ lineTexture = applyTAttr . LineTexture . Last
 lineTextureA :: (HasStyle a, V a ~ R2) => LineTexture -> a -> a
 lineTextureA = applyTAttr
 
+mkLineTexture :: Texture  -> LineTexture
+mkLineTexture = LineTexture . Last
+
+styleLineTexture :: Setter (Style v) (Style v) Texture Texture
+styleLineTexture = sets modifyLineTexture
+  where
+    modifyLineTexture f s
+      = flip setAttr s
+      . mkLineTexture
+      . f
+      . getLineTexture
+      . fromMaybe def . getAttr
+      $ s
+
 -- | 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@.
@@ -473,12 +489,30 @@ instance Transformable FillTexture where
       rgt = _RG . rGradTrans %~ f
       f = transform t
 
+instance Default FillTexture where
+    def = FillTexture (Recommend (Last (SC
+                      (SomeColor (transparent :: AlphaColour Double)))))
+
 getFillTexture :: FillTexture -> Texture
 getFillTexture (FillTexture tx) = getLast . getRecommend $ tx
 
 fillTexture :: (HasStyle a, V a ~ R2) => Texture -> a -> a
 fillTexture = applyTAttr . FillTexture . Commit . Last
 
+mkFillTexture :: Texture  -> FillTexture
+mkFillTexture = FillTexture . Commit . Last
+
+styleFillTexture :: Setter (Style v) (Style v) Texture Texture
+styleFillTexture = sets modifyFillTexture
+  where
+    modifyFillTexture f s
+      = flip setAttr s
+      . mkFillTexture
+      . f
+      . getFillTexture
+      . fromMaybe def . getAttr
+      $ s
+
 -- | The color with which shapes are filled. Note that child
 --   colors always override parent colors; that is, @'fillColor' c1
 --   . 'fillColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@.