From 9a892281ae87b25c879d98521bbfb0041c9ce3d9 Mon Sep 17 00:00:00 2001
From: Brent Yorgey <byorgey@cis.upenn.edu>
Date: Thu, 14 Nov 2013 11:47:26 -0500
Subject: [PATCH] add `fromAlphaColour` method to Color class

This allows (partial) conversions in both directions, which I found
necessary for implementing some lenses to set some color in a given
style.  Adding such a method seems generally unobjectionable to me.
---
 src/Diagrams/Attributes.hs | 21 +++++++++++++++++----
 1 file changed, 17 insertions(+), 4 deletions(-)

diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs
index 0a0240fa..b0ed3b54 100644
--- a/src/Diagrams/Attributes.hs
+++ b/src/Diagrams/Attributes.hs
@@ -25,7 +25,7 @@ module Diagrams.Attributes (
   -- * Color
   -- $color
 
-    Color(..), SomeColor(..)
+    Color(..), SomeColor(..), someToAlpha
 
   -- ** Line color
   , LineColor, getLineColor, lineColor, lineColorA, lc, lcA
@@ -90,10 +90,18 @@ class Color c where
   -- | 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@.
@@ -166,19 +174,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