bergeys proposal

src/Diagrams/Attributes.hs

@@ -28,12 +28,6 @@ module Diagrams.Attributes (
 
     Color(..), SomeColor(..)
 
-  -- ** Line color
-  , LineColor, getLineColor, lineColor, lineColorA, lc, lcA
-
-  -- ** Fill color
-  , FillColor, getFillColor, recommendFillColor, fillColor, fc, fcA
-
   -- ** Opacity
   , Opacity, getOpacity, opacity
 
@@ -95,77 +89,6 @@ class Color c where
 data SomeColor = forall c. Color c => SomeColor c
   deriving Typeable
 
--- | 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@.
---   More precisely, the semigroup structure on line color attributes
---   is that of 'Last'.
-newtype LineColor = LineColor (Last SomeColor)
-  deriving (Typeable, Semigroup)
-instance AttributeClass LineColor
-
-instance Default LineColor where
-    def = LineColor (Last (SomeColor (black :: Colour Double)))
-
-getLineColor :: LineColor -> SomeColor
-getLineColor (LineColor (Last c)) = c
-
--- | 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
-
--- | Apply a 'lineColor' attribute.
-lineColorA :: HasStyle a => LineColor -> a -> a
-lineColorA = applyAttr
-
--- | A synonym for 'lineColor', specialized to @'Colour' Double@
---   (i.e. opaque colors).
-lc :: HasStyle a => Colour Double -> a -> a
-lc = lineColor
-
--- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@
---   (i.e. colors with transparency).
-lcA :: HasStyle a => AlphaColour Double -> a -> a
-lcA = lineColor
-
--- | 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@.
---   More precisely, the semigroup structure on fill color attributes
---   is that of 'Last'.
-newtype FillColor = FillColor (Recommend (Last SomeColor))
-  deriving (Typeable, Semigroup)
-instance AttributeClass FillColor
-
--- | 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
-
--- | Set a \"recommended\" fill color, to be used only if no explicit
---   calls to 'fillColor' (or 'fc', or 'fcA') are used.
-recommendFillColor :: (Color c, HasStyle a) => c -> a -> a
-recommendFillColor = applyAttr . FillColor . Recommend . Last . SomeColor
-
-getFillColor :: FillColor -> SomeColor
-getFillColor (FillColor c) = getLast . getRecommend $ c
-
--- | A synonym for 'fillColor', specialized to @'Colour' Double@
---   (i.e. opaque colors).
-fc :: HasStyle a => Colour Double -> a -> a
-fc = fillColor
-
--- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@
---   (i.e. colors with transparency).
-fcA :: HasStyle a => AlphaColour Double -> a -> a
-fcA = fillColor
-
 instance (Floating a, Real a) => Color (Colour a) where
   toAlphaColour = opaque . colourConvert
 
@@ -175,12 +98,6 @@ instance (Floating a, Real a) => Color (AlphaColour a) where
 instance Color SomeColor where
   toAlphaColour (SomeColor c) = toAlphaColour c
 
-instance Color LineColor where
-  toAlphaColour (LineColor (Last c)) = toAlphaColour c
-
-instance Color FillColor where
-  toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c
-
 -- | Convert to an RGB space while preserving the alpha channel.
 toRGBAUsingSpace :: Color c => RGBSpace Double -> c
                             -> (Double, Double, Double, Double)

src/Diagrams/TwoD.hs

@@ -226,7 +226,7 @@ module Diagrams.TwoD
        , sized, sizedAs
 
         -- * Textures
-      , Texture(..), SpreadMethod(..), GradientStop, mkStops, getFillTexture
+      , Texture(..), SpreadMethod(..), GradientStop(..), mkStops, getFillTexture
       , fillTexture, getLineTexture, lineTexture, idTransform
 
       , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd
@@ -237,8 +237,8 @@ module Diagrams.TwoD
       , rGradSpreadMethod, defaultRG, _RG, mkRadialGradient
 
         -- ** Colors
-      , fillColorT, fcT, fcAT, recommendFillColorT
-      , lineColorT, lcT, lcAT
+      , fillColor, fc, fcA, recommendFillColor, getFillColor
+      , lineColor, lc, lcA, lineColorA, getLineColor
 
          -- * Visual aids for understanding the internal model
        , showOrigin

src/Diagrams/TwoD/Adjust.hs

@@ -24,18 +24,19 @@ module Diagrams.TwoD.Adjust
 
 import Diagrams.Core
 
-import Diagrams.Attributes  (lineWidthA, lineColorA, lineCap
-                            , lineJoin, lineMiterLimitA
-                            )
-import Diagrams.Util        ((#))
+import Diagrams.Attributes       (lineWidthA, lineCap
+                                 , lineJoin, lineMiterLimitA
+                                 )
+import Diagrams.TwoD.Attributes  (lineColorA)
+import Diagrams.Util             ((#))
 
-import Diagrams.TwoD.Types  (R2, p2)
-import Diagrams.TwoD.Size   ( size2D, center2D, SizeSpec2D(..)
-                            , requiredScaleT, requiredScale
-                            )
-import Diagrams.TwoD.Text   (fontSizeA)
+import Diagrams.TwoD.Types       (R2, p2)
+import Diagrams.TwoD.Size        ( size2D, center2D, SizeSpec2D(..)
+                                 , requiredScaleT, requiredScale
+                                 )
+import Diagrams.TwoD.Text        (fontSizeA)
 
-import Data.AffineSpace     ((.-.))
+import Data.AffineSpace          ((.-.))
 import Data.Semigroup
 
 import Data.Default.Class

src/Diagrams/TwoD/Arrow.hs

@@ -93,6 +93,7 @@ import           Diagrams.Core
 
 import           Data.Colour                      hiding (atop)
 import           Diagrams.Attributes
+import           Diagrams.TwoD.Attributes
 import           Diagrams.Parametric
 import           Diagrams.Path
 import           Diagrams.Solve                   (quadForm)
@@ -201,7 +202,7 @@ xWidth p = a + b
     b = fromMaybe 0 (magnitude <$> traceV origin unit_X p)
 
 -- | Get the line color from the shaft to use as the fill color for the joint.
-colorJoint :: Style v -> Style v
+colorJoint :: Style R2 -> Style R2
 colorJoint sStyle =
     let c = fmap getLineColor . getAttr $ sStyle in
     case c of

src/Diagrams/TwoD/Attributes.hs

@@ -6,7 +6,7 @@
 
 -----------------------------------------------------------------------------
 -- |
--- Module      :  Diagrams.Attributes
+-- Module      :  Diagrams.TwoD.Attributes
 -- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
 -- License     :  BSD-style (see LICENSE)
 -- Maintainer  :  diagrams-discuss@googlegroups.com
@@ -22,7 +22,8 @@
 module Diagrams.TwoD.Attributes (
   -- * Gradients
     Texture(..), _SC, _LG, _RG, defaultLG, defaultRG, mkStops, idTransform
-  , GradientStop, SpreadMethod(..), lineLGradient
+  , GradientStop(..), SpreadMethod(..), lineLGradient, lineRGradient
+  , stopColor, stopFraction
 
   -- ** Linear Gradients
   , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd
@@ -36,13 +37,13 @@ module Diagrams.TwoD.Attributes (
   ,  LineTexture(..), getLineTexture, lineTexture
 
   -- * Line color
-  , lineColorT, lcT, lcAT
+  , LineColor, lineColor, getLineColor, lc, lcA, lineColorA
 
   -- * Fill texture
   , FillTexture(..), getFillTexture, fillTexture
 
   -- * Fill color
-  , fillColorT, fcT, fcAT, recommendFillColorT
+  , FillColor, fillColor, getFillColor, fc, fcA, recommendFillColor
 
   ) where
 
@@ -60,7 +61,12 @@ import           Data.Monoid.Recommend
 import           Data.Semigroup
 
 -- | A stop is (color, proportion, opacity)
-type GradientStop = (SomeColor, Double, Double)
+--type GradientStop = (SomeColor, Double, Double)
+data GradientStop = GradientStop
+     { _stopColor    :: SomeColor
+     , _stopFraction :: Double}
+
+makeLenses ''GradientStop
 
 data SpreadMethod = GradPad | GradReflect | GradRepeat
 
@@ -113,16 +119,16 @@ defaultRG = RG (RGradient
     , _rGradSpreadMethod = GradPad
     })
 
-mkStops :: Color c => [(c, Double, Double)] -> [GradientStop]
-mkStops s = map (\(x, y, z) -> (SomeColor x, y, z)) s
+mkStops :: [(Colour Double, Double, Double)] -> [GradientStop]
+mkStops s = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) y) s
 
 mkLinearGradient :: [GradientStop]  -> P2 -> P2 -> SpreadMethod -> Texture
 mkLinearGradient stops  start end spreadMethod
   = LG (LGradient stops start end (scaling 1) spreadMethod)
 
 mkRadialGradient :: [GradientStop] -> Double -> P2 -> P2 -> SpreadMethod -> Texture
-mkRadialGradient stops radius center focus spreadMethod
-  = RG (RGradient stops radius center focus (scaling 1) spreadMethod)
+mkRadialGradient stops r center focus spreadMethod
+  = RG (RGradient stops r center focus (scaling 1) spreadMethod)
 
 newtype LineTexture = LineTexture (Last Texture)
   deriving (Typeable, Semigroup)
@@ -147,14 +153,48 @@ getLineTexture (LineTexture (Last t)) = t
 lineTexture :: (HasStyle a, V a ~ R2) => Texture-> a -> a
 lineTexture = applyTAttr . LineTexture . Last
 
-lineColorT :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a
-lineColorT c = lineTexture (SC (SomeColor c))
-
-lcT :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a
-lcT = lineColorT
-
-lcAT :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a
-lcAT = lineColorT
+-- | 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@.
+--   More precisely, the semigroup structure on line color attributes
+--   is that of 'Last'.
+newtype LineColor = LineColor (Last SomeColor)
+  deriving (Typeable, Semigroup)
+instance AttributeClass LineColor
+
+instance Default LineColor where
+    def = LineColor (Last (SomeColor (black :: Colour Double)))
+
+instance Color LineColor where
+  toAlphaColour (LineColor (Last c)) = toAlphaColour c
+
+getLineColor :: LineColor -> SomeColor
+getLineColor (LineColor (Last c)) = c
+
+-- | 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, V a ~ R2) => c -> a -> a
+lineColor c = (lTx c) . (lCl c)
+  where
+    lTx x = lineTexture (SC (SomeColor x))
+    lCl = applyAttr . LineColor . Last . SomeColor
+
+-- | Apply a 'lineColor' attribute.
+lineColorA :: HasStyle a => LineColor -> a -> a
+lineColorA = applyAttr
+
+-- | A synonym for 'lineColor', specialized to @'Colour' Double@
+--   (i.e. opaque colors).
+lc :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a
+lc = lineColor
+
+-- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@
+--   (i.e. colors with transparency).
+lcA :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a
+lcA = lineColor
 
 lineLGradient :: (HasStyle a, V a ~ R2) => LGradient -> a -> a
 lineLGradient g = lineTexture (LG g)
@@ -184,14 +224,45 @@ getFillTexture (FillTexture tx) = getLast . getRecommend $ tx
 fillTexture :: (HasStyle a, V a ~ R2) => Texture -> a -> a
 fillTexture = applyTAttr . FillTexture . Commit . Last
 
-fillColorT :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a
-fillColorT c = fillTexture (SC (SomeColor c))
-
-recommendFillColorT :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a
-recommendFillColorT = applyTAttr . FillTexture . Recommend . Last . SC . SomeColor
-
-fcT :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a
-fcT = fillColorT
-
-fcAT :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a
-fcAT = fillColorT
+-- | 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@.
+--   More precisely, the semigroup structure on fill color attributes
+--   is that of 'Last'.
+newtype FillColor = FillColor (Recommend (Last SomeColor))
+  deriving (Typeable, Semigroup)
+instance AttributeClass FillColor
+
+instance Color FillColor where
+  toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c
+
+-- | 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, V a ~ R2) => c -> a -> a
+fillColor c = (fTx c) . (fCl c)
+  where
+    fTx x = fillTexture (SC (SomeColor x))
+    fCl  = applyAttr . FillColor . Commit . Last . SomeColor
+
+-- | Set a \"recommended\" fill color, to be used only if no explicit
+--   calls to 'fillColor' (or 'fc', or 'fcA') are used.
+recommendFillColor :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a
+recommendFillColor c = (fT c) . (fC c)
+  where
+    fT = applyTAttr . FillTexture . Recommend . Last . SC . SomeColor
+    fC = applyAttr . FillColor . Recommend . Last . SomeColor
+
+getFillColor :: FillColor -> SomeColor
+getFillColor (FillColor c) = getLast . getRecommend $ c
+
+-- | A synonym for 'fillColor', specialized to @'Colour' Double@
+--   (i.e. opaque colors).
+fc :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a
+fc = fillColor
+
+-- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@
+--   (i.e. colors with transparency).
+fcA :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a
+fcA = fillColor

src/Diagrams/TwoD/Combinators.hs

@@ -45,20 +45,21 @@ import           Data.VectorSpace
 
 import           Diagrams.Core
 
-import           Diagrams.Attributes     (fc, lw)
+import           Diagrams.Attributes      (lw)
+import           Diagrams.TwoD.Attributes (fc)
 import           Diagrams.BoundingBox
 import           Diagrams.Combinators
 import           Diagrams.Coordinates
 import           Diagrams.Path
 import           Diagrams.Segment
 import           Diagrams.TrailLike
 import           Diagrams.TwoD.Align
-import           Diagrams.TwoD.Path      ()
+import           Diagrams.TwoD.Path       ()
 import           Diagrams.TwoD.Shapes
-import           Diagrams.TwoD.Transform (scaleX, scaleY)
+import           Diagrams.TwoD.Transform  (scaleX, scaleY)
 import           Diagrams.TwoD.Types
-import           Diagrams.TwoD.Vector    (fromDirection, unitX, unitY)
-import           Diagrams.Util           (( # ))
+import           Diagrams.TwoD.Vector     (fromDirection, unitX, unitY)
+import           Diagrams.Util            (( # ))
 
 
 infixl 6 ===

src/Diagrams/TwoD/Model.hs

@@ -24,6 +24,7 @@ import           Control.Lens          (makeLenses, (^.))
 
 import           Diagrams.Core
 import           Diagrams.Attributes
+import           Diagrams.TwoD.Attributes
 import           Diagrams.Path
 import           Diagrams.TwoD.Ellipse
 import           Diagrams.TwoD.Path