colors 0.2.0.1 → 0.3

raw patch · 4 files changed

+57/−88 lines, 4 filesdep +lensdep +linearPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, linear

API changes (from Hackage documentation)

Files

• Data/Color.hs +30/−43
• Data/Color/Class.hs +14/−29
• Data/Color/Names.hs +9/−9
• colors.cabal +4/−7

@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 707
+{-# LANGUAGE PatternSynonyms #-}
+#endif
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.RGBA
@@ -26,61 +30,46 @@ import Foreign.Storable
 import Foreign.Ptr
 import Control.Applicative
+import Linear
 
 type Color = RGBA
 
--- | A color that has red, green, blue, alpha as its components.
--- It is an instance of 'HasRGB' so there are some lenses to tweak individual components.
-data RGBA = RGBA Float Float Float Float deriving (Show, Read, Eq, Ord)
+type RGBA = V4
 
-instance Storable RGBA where
-    sizeOf _ = sizeOf (0 :: Float) * 4
-    alignment _ = 0
-    peek ptr = RGBA
-        <$> peekElemOff (castPtr ptr) 0 
-        <*> peekElemOff (castPtr ptr) 1
-        <*> peekElemOff (castPtr ptr) 2
-        <*> peekElemOff (castPtr ptr) 3
-    poke ptr (RGBA r g b a) = do
-        pokeElemOff (castPtr ptr) 0 r
-        pokeElemOff (castPtr ptr) 1 g
-        pokeElemOff (castPtr ptr) 2 b
-        pokeElemOff (castPtr ptr) 3 a
+#if __GLASGOW_HASKELL__ >= 707
+pattern RGBA a b c d = V4 a b c d
+#endif
 
-instance HasRGB RGBA where
-    fromRGB r g b = RGBA r g b 1.0
-    _Red f (RGBA r g b a) = fmap (\r' -> RGBA r' g b a) (f r)
-    _Green f (RGBA r g b a) = fmap (\g' -> RGBA r g' b a) (f g)
-    _Blue f (RGBA r g b a) = fmap (\b' -> RGBA r g b' a) (f b)
+instance HasRGB V4 where
+    fromRGB r g b = V4 r g b 1.0
+    _Red = _x
+    _Green = _y
+    _Blue = _z
 
-instance HasHSB RGBA where
+instance HasHSB V4 where
     fromHSB h s v = hsv_rgb h s v (argb 1.0)
     _Hue f (RGBA r g b a) = rgb_hsv r g b $ \h s v -> fmap (\h' -> hsv_rgb h' s v (argb a)) (f h)
     _Saturation f (RGBA r g b a) = rgb_hsv r g b $ \h s v -> fmap (\s' -> hsv_rgb h s' v (argb a)) (f s)
     _Brightness f (RGBA r g b a) = rgb_hsv r g b $ \h s v -> fmap (\v' -> hsv_rgb h s v' (argb a)) (f v)
 
-instance HasAlpha RGBA where
-    _Alpha f (RGBA r g b a) = fmap (\a' -> RGBA r g b a') (f a)
+instance HasAlpha V4 where
+    _Alpha = _w
 
-instance IsString RGBA where
-    fromString xs@[r,g,b,a] | all isHexDigit xs = RGBA (hf r) (hf g) (hf b) (hf a)
-    fromString xs@[r,g,b] | all isHexDigit xs = RGBA (hf r) (hf g) (hf b) 1
-    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = RGBA (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
-    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = RGBA (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
+instance Fractional a => IsString (V4 a) where
+    fromString xs@[r,g,b,a] | all isHexDigit xs = V4 (hf r) (hf g) (hf b) (hf a)
+    fromString xs@[r,g,b] | all isHexDigit xs = V4 (hf r) (hf g) (hf b) 1
+    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = V4 (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
+    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = V4 (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
     fromString x = error $ "Invalid color representation: " ++ x
 
 -- | Blend two colors.
-blend :: Float -> RGBA -> RGBA -> RGBA
-blend t (RGBA r0 g0 b0 a0) (RGBA r1 g1 b1 a1) = RGBA
-    (r0 * (1 - t) + r1 * t)
-    (g0 * (1 - t) + g1 * t)
-    (b0 * (1 - t) + b1 * t)
-    (a0 * (1 - t) + a1 * t)
+blend :: (Functor f, Additive f, Num a) => a -> f a -> f a -> f a
+blend t a b = (1 - t) *^ a ^+^ t *^ b
 
-argb :: Float -> Float -> Float -> Float -> RGBA
+argb :: a -> a -> a -> a -> V4 a
 argb a r g b = RGBA r g b a
 
-rgb_hsv :: Float -> Float -> Float -> (Float -> Float -> Float -> a) -> a
+rgb_hsv :: RealFrac a => a -> a -> a -> (a -> a -> a -> r) -> r
 rgb_hsv r g b f = f h (s / maxC) maxC where
     maxC = r `max` g `max` b
     minC = r `min` g `min` b
@@ -90,7 +79,7 @@       | maxC == b = (r - g) / s * 60 + 240
       | otherwise = undefined
 
-hsv_rgb :: Float -> Float -> Float -> (Float -> Float -> Float -> a) -> a
+hsv_rgb :: RealFrac a => a -> a -> a -> (a -> a -> a -> r) -> r
 hsv_rgb h s v r
     | h' == 0 = r v t p
     | h' == 1 = r q v p
@@ -104,13 +93,11 @@         f = h / 60 - fromIntegral h'
         p = v * (1 - s)
         q = v * (1 - f * s)
-        t = v * (1 - (1 - f) * s)    
+        t = v * (1 - (1 - f) * s)
 
-hf :: Char -> Float
 hf x = fromIntegral (digitToInt x) / 15
 
-hf' :: Char -> Char -> Float
 hf' x y = fromIntegral (digitToInt x * 16 + digitToInt y) / 255
 
-multRGBA :: RGBA -> RGBA -> RGBA
-multRGBA (RGBA r0 g0 b0 a0) (RGBA r1 g1 b1 a1) = RGBA (r0 * r1) (g0 * g1) (b0 * b1) (a0 * a1)
+{-# DEPRECATED multRGBA "Use (*) instead" #-}
+multRGBA = (*)

@@ -15,37 +15,22 @@ 
 import Data.Profunctor
 import Data.Word
+import Control.Lens
 
-class HasRGB a where
-    fromRGB :: Float -> Float -> Float -> a
-    -- | @'_Red' :: Lens' 'a' 'Float'@
-    _Red :: Functor f => (Float -> f Float) -> a -> f a
-    -- | @'_Green' :: Lens' 'a' 'Float'@
-    _Green :: Functor f => (Float -> f Float) -> a -> f a
-    -- | @'_Blue' :: Lens' 'a' 'Float'@
-    _Blue :: Functor f => (Float -> f Float) -> a -> f a
+class HasRGB f where
+    fromRGB :: RealFrac a => a -> a -> a -> f a
+    _Red :: RealFrac a => Lens' (f a) a
+    _Green :: RealFrac a => Lens' (f a) a
+    _Blue :: RealFrac a => Lens' (f a) a
 
-class HasHSB a where
-    fromHSB :: Float -> Float -> Float -> a
-    -- | @'_Hue' :: Lens' 'a' 'Float'@
-    _Hue :: Functor f => (Float -> f Float) -> a -> f a
-    -- | @'_Saturation' :: Lens' 'a' 'Float'@
-    _Saturation :: Functor f => (Float -> f Float) -> a -> f a
-    -- | @'_Brightness' :: Lens' 'a' 'Float'@
-    _Brightness :: Functor f => (Float -> f Float) -> a -> f a
+class HasHSB f where
+    fromHSB :: RealFrac a => a -> a -> a -> f a
+    _Hue :: RealFrac a => Lens' (f a) a
+    _Saturation :: RealFrac a => Lens' (f a) a
+    _Brightness :: RealFrac a => Lens' (f a) a
 
-class HasAlpha a where
-    -- | @'_Alpha' :: Lens' 'a' 'Float'@
-    _Alpha :: Functor f => (Float -> f Float) -> a -> f a
+class HasAlpha f where
+    _Alpha :: Lens' (f a) a
 
--- | @'_8Bit' :: Iso' 'Float' 'Word8'@
-_8Bit :: forall p f. (Profunctor p, Functor f) => p Word8 (f Word8) -> p Float (f Float)
+_8Bit :: RealFrac a => Iso' a Word8
 _8Bit = dimap (floor.(*255)) (fmap ((/255) . fromIntegral))
-
-{-
-class HasCMYK a where
-    _Cyan :: Functor f => (Float -> f Float) -> a -> f a
-    _Magenta :: Functor f => (Float -> f Float) -> a -> f a
-    _Yellow :: Functor f => (Float -> f Float) -> a -> f a
-    _KeyPlate :: Functor f => (Float -> f Float) -> a -> f a
--}

@@ -13,29 +13,29 @@ module Data.Color.Names where
 import Data.Color.Class
 
-white :: HasRGB a => a
+white :: (HasRGB f, RealFrac a) => f a
 white = fromRGB 1.0 1.0 1.0
 
-gray :: HasRGB a => a
+gray :: (HasRGB f, RealFrac a) => f a
 gray = fromRGB 0.5 0.5 0.5
 
-black :: HasRGB a => a
+black :: (HasRGB f, RealFrac a) => f a
 black = fromRGB 0.0 0.0 0.0
 
-red :: HasRGB a => a
+red :: (HasRGB f, RealFrac a) => f a
 red = fromRGB 1.0 0.0 0.0
 
-green :: HasRGB a => a
+green :: (HasRGB f, RealFrac a) => f a
 green = fromRGB 0.0 1.0 0.0
 
-blue :: HasRGB a => a
+blue :: (HasRGB f, RealFrac a) => f a
 blue = fromRGB 0.0 0.0 1.0
 
-yellow :: HasRGB a => a
+yellow :: (HasRGB f, RealFrac a) => f a
 yellow = fromRGB 1.0 1.0 0.0
 
-cyan :: HasRGB a => a
+cyan :: (HasRGB f, RealFrac a) => f a
 cyan = fromRGB 0.0 1.0 1.0
 
-magenta :: HasRGB a => a
+magenta :: (HasRGB f, RealFrac a) => f a
 magenta = fromRGB 1.0 0.0 1.0

@@ -1,10 +1,7 @@--- Initial colors.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
-
 name:                colors
-version:             0.2.0.1
+version:             0.3
 synopsis:            A type for colors
--- description:         
+-- description:
 homepage:            https://github.com/fumieval/colors
 license:             BSD3
 license-file:        LICENSE
@@ -21,5 +18,5 @@ 
 library
   exposed-modules:     Data.Color, Data.Color.Names, Data.Color.Class
-  -- other-modules:       
-  build-depends:       base ==4.*, profunctors >= 3 && < 5
+  -- other-modules:
+  build-depends:       base ==4.*, profunctors >= 3 && < 5, linear, lens >= 4.0 && <5