Color 0.1.2 → 0.1.3

raw patch · 26 files changed

+273/−99 lines, 26 filesdep +massivdep +massiv-testPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: massiv, massiv-test

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• Color.cabal +4/−1
• src/Graphics/Color/Adaptation/VonKries.hs +76/−36
• src/Graphics/Color/Illuminant/CIE1931.hs +1/−1
• src/Graphics/Color/Model/Alpha.hs +10/−4
• src/Graphics/Color/Model/Y.hs +1/−1
• src/Graphics/Color/Space/Internal.hs +15/−7
• src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs +35/−0
• src/Graphics/Color/Space/RGB/Luma.hs +7/−6
• tests/Graphics/Color/Illuminant/CIE1931Spec.hs +20/−1
• tests/Graphics/Color/Model/Common.hs +38/−9
• tests/Graphics/Color/Space/CIE1976/LABSpec.hs +1/−1
• tests/Graphics/Color/Space/Common.hs +17/−17
• tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs +1/−1
• tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs +1/−1
• tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs +1/−1
• tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs +1/−1
• tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs +1/−1
• tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs +2/−2
• tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs +1/−1
• tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs +1/−1
• tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs +2/−2
• tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs +2/−2
• tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs +1/−1
• tests/Graphics/Color/Space/RGB/SRGBSpec.hs +1/−1
• tests/Graphics/Color/SpaceSpec.hs +25/−0

@@ -1,5 +1,13 @@ # Changelog for color +## 0.1.3++* Addition of `CMCCAT2000`.+* Rename `CIECAM02` to `CIECAT02` with a fallback synonym for backwards compatibility+* Fix `ColorSpace` instance for `Alpha cs`+* Add `ColorSpace` instances for `YCbCr cs` color spaces that have `Luma` instance:+  `BT709`, `BT601_525` and `BT601_625`+ ## 0.1.2  * Fix `YCbCr` conversion to derived RGB color spaces

@@ -1,5 +1,5 @@ name:                Color-version:             0.1.2+version:             0.1.3 synopsis:            Color spaces and conversions between them description:         Please see the README on GitHub at <https://github.com/lehins/Color#readme> homepage:            https://github.com/lehins/Color@@ -130,6 +130,7 @@                     , Graphics.Color.Space.RGB.Alternative.HSLSpec                     , Graphics.Color.Space.RGB.Alternative.HSVSpec                     , Graphics.Color.Space.RGB.Alternative.YCbCrSpec+                    , Graphics.Color.SpaceSpec                     , Graphics.Color.Standard.RALSpec                     , Spec   build-depends:      JuicyPixels@@ -141,6 +142,8 @@                     , hspec                     , random                     , vector+                    , massiv+                    , massiv-test    default-language:   Haskell2010   ghc-options:        -Wall

@@ -30,8 +30,12 @@   , vonKriesAdaptation   , bradfordAdaptation   , fairchildAdaptation-  , ciecam02Adaptation+  , ciecat02Adaptation+  , cmccat2000Adaptation   , adaptationMatrix+  -- * Deprecated+  , CIECAM02+  , ciecam02Adaptation   ) where  import Data.Coerce@@ -44,7 +48,7 @@  data VonKries   = VonKries-  -- ^ VonKries chromatic adaptation transform matrix+  -- ^ VonKries chromatic adaptation transform   --   -- >>> cat :: CAT 'VonKries Float   -- CAT VonKries 'VonKries Float@@ -56,8 +60,10 @@   -- [ [ 1.859936,-1.129382, 0.219897 ]   -- , [ 0.361191, 0.638812,-0.000006 ]   -- , [-0.000000,-0.000000, 1.089064 ] ]+  --+  -- @since 0.1.0   | Bradford-  -- ^ Bradford chromatic adaptation transform matrix+  -- ^ Bradford chromatic adaptation transform   --   -- >>> cat :: CAT 'Bradford Float   -- CAT VonKries 'Bradford Float@@ -69,8 +75,10 @@   -- [ [ 0.986993,-0.147054, 0.159963 ]   -- , [ 0.432305, 0.518360, 0.049291 ]   -- , [-0.008529, 0.040043, 0.968487 ] ]+  --+  -- @since 0.1.0   | Fairchild-  -- ^ Fairchild chromatic adaptation transform matrix+  -- ^ Fairchild chromatic adaptation transform   --   -- >>> cat :: CAT 'Fairchild Float   -- CAT VonKries 'Fairchild Float@@ -82,21 +90,40 @@   -- [ [ 0.987400,-0.176825, 0.189425 ]   -- , [ 0.450435, 0.464933, 0.084632 ]   -- , [-0.013968, 0.027807, 0.986162 ] ]-  | CIECAM02-  -- ^ CIECAM02 chromatic adaptation transform matrix   ---  -- >>> cat :: CAT 'CIECAM02 Float-  -- CAT VonKries 'CIECAM02 Float+  -- @since 0.1.0+  | CIECAT02+  -- ^ CIECAT02 chromatic adaptation transform+  --+  -- >>> cat :: CAT 'CIECAT02 Float+  -- CAT VonKries 'CIECAT02 Float   -- [ [ 0.732800, 0.429600,-0.162400 ]   -- , [-0.703600, 1.697500, 0.006100 ]   -- , [ 0.003000, 0.013600, 0.983400 ] ]-  -- >>> icat :: ICAT 'CIECAM02 Float-  -- ICAT VonKries 'CIECAM02 Float+  -- >>> icat :: ICAT 'CIECAT02 Float+  -- ICAT VonKries 'CIECAT02 Float   -- [ [ 1.096124,-0.278869, 0.182745 ]   -- , [ 0.454369, 0.473533, 0.072098 ]   -- , [-0.009628,-0.005698, 1.015326 ] ]+  --+  -- @since 0.1.3+  | CMCCAT2000+  -- ^ CMCCAT2000 chromatic adaptation transform+  --+  -- >>> cat :: CAT 'CMCCAT2000 Float+  -- CAT VonKries 'CMCCAT2000 Float+  -- [ [ 0.798200, 0.338900,-0.137100 ]+  -- , [-0.591800, 1.551200, 0.040600 ]+  -- , [ 0.000800, 0.023900, 0.975300 ] ]+  -- >>> icat :: ICAT 'CMCCAT2000 Float+  -- ICAT VonKries 'CMCCAT2000 Float+  -- [ [ 1.076450,-0.237662, 0.161212 ]+  -- , [ 0.410964, 0.554342, 0.034694 ]+  -- , [-0.010954,-0.013389, 1.024343 ] ]+  --+  -- @since 0.1.3 --- | Chromatic adaptation transformation matrix matrix+-- | Chromatic adaptation transformation matrix newtype CAT (t :: k) e =   CAT (M3x3 e)   deriving (Eq)@@ -134,12 +161,16 @@                   (V3 -0.8360  1.8327  0.0033)                   (V3  0.0357 -0.0469  1.0112)) --instance ChromaticAdaptationTransform 'CIECAM02 where+instance ChromaticAdaptationTransform 'CIECAT02 where   cat = CAT (M3x3 (V3  0.7328  0.4296 -0.1624)                   (V3 -0.7036  1.6975  0.0061)                   (V3  0.0030  0.0136  0.9834)) +instance ChromaticAdaptationTransform 'CMCCAT2000 where+  cat = CAT (M3x3 (V3  0.7982  0.3389 -0.1371)+                  (V3 -0.5918  1.5512  0.0406)+                  (V3  0.0008  0.0239  0.9753))+ instance (Illuminant it, Illuminant ir, Elevator e, RealFloat e) =>          ChromaticAdaptation (t :: VonKries) (it :: kt) (ir :: kr) e where   newtype Adaptation (t :: VonKries) (it :: kt) (ir :: kr) e =@@ -169,21 +200,52 @@     wpTest = coerce (whitePointTristimulus :: Color (XYZ it) e)     wpRef = coerce (whitePointTristimulus :: Color (XYZ ir) e) +-- | `VonKries` chromatic adaptation transform.+--+-- @since 0.1.2 vonKriesAdaptation :: ChromaticAdaptation 'VonKries it ir e => Adaptation 'VonKries it ir e vonKriesAdaptation = adaptationMatrix {-# INLINE vonKriesAdaptation #-} +-- | `Fairchild` chromatic adaptation transform.+--+-- @since 0.1.2 fairchildAdaptation :: ChromaticAdaptation 'Fairchild it ir e => Adaptation 'Fairchild it ir e fairchildAdaptation = adaptationMatrix {-# INLINE fairchildAdaptation #-} +-- | `Bradford` chromatic adaptation transform, as defined in the+-- [CIECAM97s](https://en.wikipedia.org/wiki/Color_appearance_model#CIECAM97s) color+-- appearance model.+--+-- @since 0.1.2 bradfordAdaptation :: ChromaticAdaptation 'Bradford it ir e => Adaptation 'Bradford it ir e bradfordAdaptation = adaptationMatrix {-# INLINE bradfordAdaptation #-} -ciecam02Adaptation :: ChromaticAdaptation 'CIECAM02 it ir e => Adaptation 'CIECAM02 it ir e+-- | `CIECAT02` chromatic adaptation as defined it+-- [CIECAM02](https://en.wikipedia.org/wiki/CIECAM02) color appearance model+--+-- @since 0.1.3+ciecat02Adaptation :: ChromaticAdaptation 'CIECAT02 it ir e => Adaptation 'CIECAT02 it ir e+ciecat02Adaptation = adaptationMatrix+{-# INLINE ciecat02Adaptation #-}++-- | `CMCCAT2000` chromatic adaptation. Predecessor of `CIECAT02`. as defined it+-- [CIECAM02](https://en.wikipedia.org/wiki/CIECAM02) color appearance model+--+-- @since 0.1.3+cmccat2000Adaptation :: ChromaticAdaptation 'CMCCAT2000 it ir e => Adaptation 'CIECAT02 it ir e+cmccat2000Adaptation = adaptationMatrix+{-# INLINE cmccat2000Adaptation #-}++type CIECAM02 = 'CIECAT02+{-# DEPRECATED CIECAM02 "In favor of a proper name 'CIECAT02'" #-}++ciecam02Adaptation :: ChromaticAdaptation CIECAM02 it ir e => Adaptation CIECAM02 it ir e ciecam02Adaptation = adaptationMatrix {-# INLINE ciecam02Adaptation #-}+{-# DEPRECATED ciecam02Adaptation "In favor of a proper name 'ciecat02Adaptation'" #-}  -- | This function allows conversion of a color between any two color spaces. It uses a -- very common `VonKries` chromatic adaptation transform with `Bradford` matrix. One of@@ -195,25 +257,3 @@ convert :: (ColorSpace cs' i' e', ColorSpace cs i e) => Color cs' e' -> Color cs e convert = convertElevatedWith (adaptationMatrix @'Bradford @_ @_ @Double) {-# INLINE convert #-}----- RAL adopted: Daffodil yellow--- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Float) (toColorXYZ (ColorLAB 66.5 27.308 80.402 :: Color (LAB D50a) Float) :: Color XYZ Float)) :: Color SRGB Float)--- <RGB:(226,141,  0)>-------- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Double) (toColorXYZ (ColorLAB 83.353 3.462 75.829 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double)--- <RGB:(242,203, 46)>----- -- Green beige--- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Double) (toColorXYZ (ColorLAB 76.022 (-0.366) 27.636 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double)--- <RGB:(201,187,136)>---- From srgb spec--- srgbVonKries :: VonKriesAdaptationMatrix t it ir Double--- srgbVonKries = VonKriesAdaptationMatrix $ M3x3---       (V3  1.047844353856414 0.022898981050086 -0.050206647741605)---       (V3  0.029549007606644 0.990508028941971 -0.017074711360960)---       (V3 -0.009250984365223 0.015072338237051  0.751717835079977)

@@ -546,7 +546,7 @@ -- -- All of the values were taken directly from: /CIE15: Technical Report: Colorimetry, 3rd edition/ ----- ![colorMatchingFunctions](files/colorMatchingFunctions.png)+-- ![colorMatchingFunctions](files/colorMatchingFunctions.svg) -- -- @since 0.1.2 xyzColorMatchingFunctions :: [(Double, V3 Double, V2 Double)]

@@ -16,6 +16,7 @@ module Graphics.Color.Model.Alpha   ( Alpha   , Opaque+  , Transparent   , addAlpha   , getAlpha   , setAlpha@@ -85,21 +86,26 @@   (==) (Alpha px1 a1) (Alpha px2 a2) = px1 == px2 && a1 == a2   {-# INLINE (==) #-} -instance (ColorModel cs e, Opaque (Alpha cs) ~ cs) => Show (Color (Alpha cs) e) where+instance (ColorModel cs e, cs ~ Opaque (Alpha cs), Alpha cs ~ Transparent cs) =>+         Show (Color (Alpha cs) e) where   showsPrec _ = showsColorModel  type family Opaque cs where   Opaque (Alpha (Alpha cs)) = TypeError ('Text "Nested alpha channels are not allowed")   Opaque (Alpha cs) = cs-  Opaque cs = cs -instance (ColorModel cs e, Opaque (Alpha cs) ~ cs) => ColorModel (Alpha cs) e where+type family Transparent cs where+  Transparent (Alpha cs) = TypeError ('Text "Nested alpha channels are not allowed")+  Transparent cs = Alpha cs++instance (ColorModel cs e, cs ~ Opaque (Alpha cs), Alpha cs ~ Transparent cs) =>+         ColorModel (Alpha cs) e where   type Components (Alpha cs) e = (Components cs e, e)   toComponents (Alpha px a) = (toComponents px, a)   {-# INLINE toComponents #-}   fromComponents (pxc, a) = Alpha (fromComponents pxc) a   {-# INLINE fromComponents #-}-  showsColorModelName _ = showsColorModelName (Proxy :: Proxy (Color cs e)) . ('A':)+  showsColorModelName _ = ("Alpha (" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) . (')':)   instance Functor (Color cs) => Functor (Color (Alpha cs)) where

@@ -106,4 +106,4 @@  newtype Weights e = Weights   { unWeights :: V3 e-  }+  } deriving (Eq, Num, Show, Fractional, Floating, Functor)

@@ -64,7 +64,7 @@ import GHC.TypeNats import Data.Kind -class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e, Typeable (Opaque cs)) =>+class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) =>   ColorSpace cs (i :: k) e | cs -> i where    type BaseModel cs :: Type@@ -106,21 +106,29 @@   instance ( ColorSpace cs i e-         , Opaque (Alpha cs) ~ cs-         , Opaque (Alpha (BaseModel cs)) ~ BaseModel cs) =>+         , ColorSpace (BaseSpace cs) i e+         , ColorSpace (Alpha (BaseSpace cs)) i e+         , cs ~ Opaque (Alpha cs)+         , Alpha cs ~ Transparent cs+         , BaseModel cs ~ Opaque (Alpha (BaseModel cs))+         , Alpha (BaseModel cs) ~ Transparent (BaseModel cs)+         ) =>          ColorSpace (Alpha cs) i e where   type BaseModel (Alpha cs) = Alpha (BaseModel cs)-  type BaseSpace (Alpha cs) = cs-+  type BaseSpace (Alpha cs) = Alpha (BaseSpace cs)   toBaseModel = modifyOpaque toBaseModel   {-# INLINE toBaseModel #-}   fromBaseModel = modifyOpaque fromBaseModel   {-# INLINE fromBaseModel #-}+  toColorXYZ = toColorXYZ . dropAlpha+  {-# INLINE toColorXYZ #-}+  fromColorXYZ = (`addAlpha` maxValue) . fromColorXYZ+  {-# INLINE fromColorXYZ #-}   luminance = luminance . dropAlpha   {-# INLINE luminance #-}-  toBaseSpace = dropAlpha+  toBaseSpace = modifyOpaque toBaseSpace   {-# INLINE toBaseSpace #-}-  fromBaseSpace c = Alpha c maxValue+  fromBaseSpace = modifyOpaque fromBaseSpace   {-# INLINE fromBaseSpace #-}  -- | This is a data type that encodes a data point on the chromaticity diagram

@@ -39,6 +39,8 @@ import qualified Graphics.Color.Model.YCbCr as CM import Graphics.Color.Space import Graphics.Color.Space.RGB.SRGB+import Graphics.Color.Space.RGB.ITU.Rec601+import Graphics.Color.Space.RGB.ITU.Rec709 import Graphics.Color.Space.RGB.Luma  -- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space@@ -93,6 +95,39 @@   toBaseSpace = fmap fromRealFloat . ycbcr2srgb . fmap toFloat   {-# INLINE toBaseSpace #-}   fromBaseSpace = fmap fromRealFloat . srgb2ycbcr . fmap toFloat+  {-# INLINE fromBaseSpace #-}+  luminance = luminance . toBaseSpace+  {-# INLINE luminance #-}++-- | `YCbCr` representation for `BT601_525` color space+instance Elevator e => ColorSpace (YCbCr BT601_525) D65 e where+  type BaseModel (YCbCr BT601_525) = CM.YCbCr+  type BaseSpace (YCbCr BT601_525) = BT601_525+  toBaseSpace = fmap fromDouble . fromColorYCbCr+  {-# INLINE toBaseSpace #-}+  fromBaseSpace = fmap fromDouble . toColorYCbCr+  {-# INLINE fromBaseSpace #-}+  luminance = luminance . toBaseSpace+  {-# INLINE luminance #-}++-- | `YCbCr` representation for `BT601_625` color space+instance Elevator e => ColorSpace (YCbCr BT601_625) D65 e where+  type BaseModel (YCbCr BT601_625) = CM.YCbCr+  type BaseSpace (YCbCr BT601_625) = BT601_625+  toBaseSpace = fmap fromDouble . fromColorYCbCr+  {-# INLINE toBaseSpace #-}+  fromBaseSpace = fmap fromDouble . toColorYCbCr+  {-# INLINE fromBaseSpace #-}+  luminance = luminance . toBaseSpace+  {-# INLINE luminance #-}++-- | `YCbCr` representation for `BT709` color space+instance Elevator e => ColorSpace (YCbCr BT709) D65 e where+  type BaseModel (YCbCr BT709) = CM.YCbCr+  type BaseSpace (YCbCr BT709) = BT709+  toBaseSpace = fmap fromDouble . fromColorYCbCr+  {-# INLINE toBaseSpace #-}+  fromBaseSpace = fmap fromDouble . toColorYCbCr   {-# INLINE fromBaseSpace #-}   luminance = luminance . toBaseSpace   {-# INLINE luminance #-}

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -9,19 +10,19 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.Luma--- Copyright   : (c) Alexey Kuleshevich 2018-2019+-- Copyright   : (c) Alexey Kuleshevich 2018-2020 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable -- module Graphics.Color.Space.RGB.Luma-  ( Y'-  -- * Constructors for Luma.-  , pattern Y'-  , Color+  ( -- * Luma+    pattern Y'+  , Y'   , Luma(..)   , Weight(..)+  , Weights(..)   , rgbLuma   , rgbLumaWeights   ) where@@ -109,7 +110,7 @@  newtype Weight cs e = Weight   { unWeight :: e-  } deriving (Eq, Show, Num, Fractional, Floating)+  } deriving (Eq, Show, Num, Fractional, Floating, Functor)   rgbLumaWeights ::

@@ -60,7 +60,26 @@       it "Enum" $ forM_ is $ \ i -> toEnum (fromEnum i) `shouldBe` i       it "Read . Show" $ forM_ is $ \ i -> read (show i) `shouldBe` i       it "Read . Show" $  read (show is) `shouldBe` (is :: [CIE1931])-+    describe "Data" $ do+      describe "Wavelength is in 5nm intervals" $ do+        it "spectralPowerDistributions" $+          map fst spectralPowerDistributions `shouldBe`+          map fromIntegral [300, 305 .. 830 :: Int]+        it "xyzColorMatchingFunctions" $+          [w | (w, _, _) <- xyzColorMatchingFunctions] `shouldBe`+          map fromIntegral [380, 385 .. 780 :: Int]+      describe "Sum" $ do+        it "spectralPowerDistributions" $+          epsilonFoldableExpect epsilon (sum (map snd spectralPowerDistributions))+            (V3 8715.51 890.13 374.95)+        it "xyzColorMatchingFunctions (x̄(λ) ȳ(λ) z̄(λ))" $+          epsilonFoldableExpect epsilon (sum [xyz | (_, xyz, _) <- xyzColorMatchingFunctions])+            (V3 21.371524 21.371327 21.37154)+        it "xyzColorMatchingFunctions (x(λ) z(λ))" $+          epsilonFoldableExpect epsilon (sum [xy | (_, _, xy) <- xyzColorMatchingFunctions])+            (V2 35.7978 24.58414)+  where+    epsilon = 1e-12  daylightChromaticityY :: RealFloat a => a -> a daylightChromaticityY x = 2.87 * x - 3 * x ^ (2 :: Int) - 0.275

@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -10,6 +11,7 @@   , matchListsWith   , expectSameLength   , epsilonExpect+  , epsilonFoldableExpect   , epsilonColorExpect   , epsilonColorIxSpec   , epsilonEq@@ -32,21 +34,32 @@   , module F   ) where -import Data.Proxy+import Prelude as P+import Control.Monad as M import Data.Foldable as F+import Data.Massiv.Array as A+import Data.Proxy import Graphics.Color.Model import System.Random import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit (assertBool)+import Test.Massiv.Array.Mutable import Test.QuickCheck-import Control.Monad +instance (Random e, ColorModel cs e, Arbitrary (Color cs e)) => Arbitrary (Color (Alpha cs) e) where+  arbitrary = addAlpha <$> arbitrary <*> arbitraryElevator +instance (ColorModel cs e, CoArbitrary (Components cs e)) => CoArbitrary (Color cs e) where+  coarbitrary c = coarbitrary (toComponents c)++instance (Function (Components cs e), ColorModel cs e) => Function (Color cs e) where+  function = functionMap toComponents fromComponents+ infix 1 `epsilonEqFloat`, `epsilonEqDouble`, `approxIntegralColorExpect1`  izipWithM_ :: Applicative m => (Int -> a -> b -> m c) -> [a] -> [b] -> m ()-izipWithM_ f xs = zipWithM_ (uncurry f) (zip [0..] xs)+izipWithM_ f xs = zipWithM_ (uncurry f) (P.zip [0..] xs)   -- | Match to lists exactly element-by-element with an expectation.@@ -98,7 +111,7 @@   -> a -- ^ Tested value.   -> Expectation epsilonExpect epsilon x y =-  forM_ (epsilonMaybeEq epsilon x y) $ \errMsg ->+  M.forM_ (epsilonMaybeEq epsilon x y) $ \errMsg ->     expectationFailure $ "Expected: " ++ show x ++ " but got: " ++ show y ++ "\n   " ++ errMsg  @@ -120,10 +133,14 @@  epsilonColorExpect ::      (HasCallStack, ColorModel cs e, RealFloat e) => e -> Color cs e -> Color cs e -> Expectation-epsilonColorExpect epsilon x y =-  forM_ (zipWithM (epsilonMaybeEq epsilon) (F.toList x) (F.toList y)) $ \errMsgs ->+epsilonColorExpect = epsilonFoldableExpect++epsilonFoldableExpect ::+     (HasCallStack, Foldable f, Show (f e), Show e, RealFloat e) => e -> f e -> f e -> Expectation+epsilonFoldableExpect epsilon x y =+  M.forM_ (zipWithM (epsilonMaybeEq epsilon) (F.toList x) (F.toList y)) $ \errMsgs ->     expectationFailure $-    "Expected: " ++ show x ++ " but got: " ++ show y ++ "\n" ++ unlines (map ("    " ++) errMsgs)+    "Expected: " ++ show x ++ " but got: " ++ show y ++ "\n" ++ unlines (P.map ("    " ++) errMsgs)  epsilonColorIxSpec ::      (HasCallStack, ColorModel cs e, RealFloat e)@@ -195,9 +212,21 @@ toFromComponentsSpec :: forall cs e . (ColorModel cs e, Arbitrary (Color cs e)) => Spec toFromComponentsSpec = prop "fromComponents . toComponents" $ prop_ToFromComponents @cs @e --colorModelSpec :: forall cs e . (ColorModel cs e, Arbitrary (Color cs e)) => String -> Spec+colorModelSpec ::+     forall cs e.+     ( ColorModel cs e+     , Function (Components cs e)+     , CoArbitrary (Components cs e)+     , Arbitrary (Color cs e)+     )+  => String+  -> Spec colorModelSpec name =   describe "ColorModel" $ do     toFromComponentsSpec @cs @e     it "Model Name" $ showsColorModelName (Proxy :: Proxy (Color cs e)) "" `shouldStartWith` name+    modifyMaxSuccess (`div` 10) $ describe "Array" $ do+      describe "Storable" $+        mutableSpec @S @Ix1 @(Color cs e)+      describe "Unboxed" $+        mutableSpec @U @Ix1 @(Color cs e)

@@ -23,7 +23,7 @@ spec :: Spec spec = describe "LAB" $ do   colorModelSpec @(LAB 'D65) @Word "LAB"-  colorSpaceLenientSpec @(LAB 'D65) @_ @Double 1e-10+  colorSpaceLenientSpec @(LAB 'D65) @Double 1e-10   describe "Same as colour package" $ do     prop "lab2srgb" $ \lab@(ColorLAB l' a' b' :: Color (LAB 'W.D65) Double) ->       case Colour.toSRGB (Colour.cieLAB Colour.d65 l' a' b') of

@@ -27,7 +27,7 @@   prop_toFromColorXYZ ::-     forall cs i e. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e)   => Color cs e   -> Property prop_toFromColorXYZ c = c `epsilonEqColor` fromColorXYZ (toColorXYZ c :: Color (XYZ i) Double)@@ -35,26 +35,26 @@  -- For RGB standards, that have matrices rounded to 4 digits after the decimal point prop_toFromLenientColorXYZ ::-     forall cs i e. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e)   => e   -> Color cs e   -> Property prop_toFromLenientColorXYZ epsilon c =   epsilonEqColorTol epsilon c (fromColorXYZ (toColorXYZ c :: Color (XYZ i) Double)) -prop_LuminanceColorXYZ :: forall cs i e . ColorSpace cs i e => Color cs e -> Property+prop_LuminanceColorXYZ :: forall cs e i . ColorSpace cs i e => Color cs e -> Property prop_LuminanceColorXYZ c =   (luminance c :: Color (Y i) Float) `epsilonEqColor`   luminance (toColorXYZ c :: Color (XYZ i) Float)  prop_toFromBaseSpace ::-     forall cs i e. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e)   => Color cs e   -> Property prop_toFromBaseSpace c = c `epsilonEqColor` fromBaseSpace (toBaseSpace c)  prop_toFromBaseSpaceLenient ::-     forall cs i e. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e)   => e   -> Color cs e   -> Property@@ -62,37 +62,37 @@   prop_toFromBaseModel ::-     forall cs i e. ColorSpace cs i e+     forall cs e i. ColorSpace cs i e   => Color cs e   -> Property prop_toFromBaseModel c = c === fromBaseModel (toBaseModel c)  colorSpaceCommonSpec ::-     forall cs i e.+     forall cs e i.      (Arbitrary (Color cs e), ColorSpace cs i e)   => Spec -> Spec colorSpaceCommonSpec extra =   describe "ColorSpace" $ do-    prop "luminance . toColorXYZ" $ prop_LuminanceColorXYZ @cs @i @e-    prop "toFromBaseModel" $ prop_toFromBaseModel @cs @i @e+    prop "luminance . toColorXYZ" $ prop_LuminanceColorXYZ @cs @e @i+    prop "toFromBaseModel" $ prop_toFromBaseModel @cs @e @i     extra  colorSpaceSpec ::-     forall cs i e.+     forall cs e i.      (Arbitrary (Color cs e), ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, RealFloat e)   => Spec colorSpaceSpec =-  colorSpaceCommonSpec @cs @i @e $ do-    prop "toFromBaseSpace" $ prop_toFromBaseSpace @cs @i @e-    prop "toFromColorXYZ" $ prop_toFromColorXYZ @cs @i @e+  colorSpaceCommonSpec @cs @e @i $ do+    prop "toFromBaseSpace" $ prop_toFromBaseSpace @cs @e @i+    prop "toFromColorXYZ" $ prop_toFromColorXYZ @cs @e @i  colorSpaceLenientSpec ::-     forall cs i e.+     forall cs e i.      (Arbitrary (Color cs e), ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, RealFloat e)   => e   -> Spec colorSpaceLenientSpec tol =   let tolStr = "(lenient=" ++ show tol ++ ")"-  in colorSpaceCommonSpec @cs @i @e $ do-       prop ("toFromBaseSpace " ++ tolStr) $ prop_toFromBaseSpaceLenient @cs @i @e tol-       prop ("toFromColorXYZ " ++ tolStr) $ prop_toFromLenientColorXYZ @cs @i @e tol+  in colorSpaceCommonSpec @cs @e @i $ do+       prop ("toFromBaseSpace " ++ tolStr) $ prop_toFromBaseSpaceLenient @cs @e @i tol+       prop ("toFromColorXYZ " ++ tolStr) $ prop_toFromLenientColorXYZ @cs @e @i tol

@@ -12,4 +12,4 @@ spec :: Spec spec = describe "AdobeRGB" $ do   colorModelSpec @AdobeRGB @Word "AdobeRGB"-  colorSpaceLenientSpec @AdobeRGB @_ @Float 0.00001+  colorSpaceLenientSpec @AdobeRGB @Float 0.00001

@@ -19,7 +19,7 @@ spec =   describe "CMYK" $ do     colorModelSpec @(CMYK (Derived.SRGB D65)) @Word "CMYK"-    colorSpaceCommonSpec @(CMYK (Derived.SRGB D65)) @_ @Double $ pure ()+    colorSpaceCommonSpec @(CMYK (Derived.SRGB D65)) @Double $ pure ()     -- Arbitrary inverse CMYKtoSRGB is not true.     prop "sRGBtoCMYK" $ \ (srgb :: Color (Derived.SRGB D65) Double) ->       toBaseSpace (fromBaseSpace srgb :: Color (CMYK (Derived.SRGB D65)) Double)

@@ -18,4 +18,4 @@   describe "HSI" $ do     describe "Derived-sRGB" $ do       colorModelSpec @(HSI (Derived.SRGB D65)) @Word "HSI"-      colorSpaceSpec @(HSI (Derived.SRGB D65)) @_ @Double+      colorSpaceSpec @(HSI (Derived.SRGB D65)) @Double

@@ -18,4 +18,4 @@   describe "HSL" $ do     describe "Derived-sRGB" $ do       colorModelSpec @(HSL (Derived.SRGB D65)) @Word "HSL"-      colorSpaceSpec @(HSL (Derived.SRGB D65)) @_ @Double+      colorSpaceSpec @(HSL (Derived.SRGB D65)) @Double

@@ -18,4 +18,4 @@   describe "HSV" $ do     describe "Derived-sRGB" $ do       colorModelSpec @(HSV (Derived.SRGB D65)) @Word "HSV"-      colorSpaceSpec @(HSV (Derived.SRGB D65)) @_ @Double+      colorSpaceSpec @(HSV (Derived.SRGB D65)) @Double

@@ -24,10 +24,10 @@   describe "YCbCr" $ do     describe "sRGB" $ do       colorModelSpec @(YCbCr SRGB) @Word "YCbCr"-      colorSpaceCommonSpec @(YCbCr SRGB) @_ @Double $ pure ()+      colorSpaceCommonSpec @(YCbCr SRGB) @Double $ pure ()     describe "Derived-sRGB" $ do       colorModelSpec @(YCbCr (Derived.SRGB D65)) @Word "YCbCr"-      colorSpaceCommonSpec @(YCbCr (Derived.SRGB D65)) @_ @Double $ pure ()+      colorSpaceCommonSpec @(YCbCr (Derived.SRGB D65)) @Double $ pure ()     prop "toColorYCbCr . toColorYCbCr" $ \(rgb :: Color (Derived.SRGB D65) Double) ->       rgb `epsilonEqColor`       fromColorYCbCr (toColorYCbCr rgb :: Color (YCbCr (Derived.SRGB D65)) Double)

@@ -17,4 +17,4 @@ spec :: Spec spec = describe "AdobeRGB" $ do   colorModelSpec @(AdobeRGB 'D65) @Word "AdobeRGB"-  colorSpaceSpec @(AdobeRGB 'D65) @_ @Float+  colorSpaceSpec @(AdobeRGB 'D65) @Float

@@ -21,7 +21,7 @@ spec :: Spec spec = describe "SRGB" $ do   colorModelSpec @(SRGB 'D65) @Word "SRGB"-  colorSpaceSpec @(SRGB 'D65) @_ @Float+  colorSpaceSpec @(SRGB 'D65) @Float   describe "Same as colour package" $ do     prop "xyz2srgb" $ \xyz@(ColorXYZ x y z :: Color (XYZ 'W.D65) Double) ->       case Colour.toSRGB (Colour.cieXYZ x y z) of

@@ -18,7 +18,7 @@ spec = do   describe "Rec470 (525)" $ do     colorModelSpec @BT470_525 @Word "BT470_525"-    colorSpaceSpec @BT470_525 @_ @Float+    colorSpaceSpec @BT470_525 @Float   describe "Rec470 (625)" $ do     colorModelSpec @BT470_625 @Word "BT470_625"-    colorSpaceSpec @BT470_625 @_ @Float+    colorSpaceSpec @BT470_625 @Float

@@ -18,7 +18,7 @@ spec = do   describe "Rec601 (525)" $ do     colorModelSpec @BT601_525 @Word "BT601_525"-    colorSpaceSpec @BT601_525 @_ @Float+    colorSpaceSpec @BT601_525 @Float   describe "Rec601 (625)" $ do     colorModelSpec @BT601_625 @Word "BT601_625"-    colorSpaceSpec @BT601_625 @_ @Float+    colorSpaceSpec @BT601_625 @Float

@@ -15,4 +15,4 @@ spec = describe "Rec709" $ do   colorModelSpec @BT709 @Word "BT709"   -- Roundrtrip is not always very accurate, eg: 8.115324539550295e-2 /= 8.140132075907752e-2-  colorSpaceLenientSpec @BT709 @_ @Float 5e-4+  colorSpaceLenientSpec @BT709 @Float 5e-4

@@ -12,4 +12,4 @@ spec :: Spec spec = describe "SRGB" $ do   colorModelSpec @SRGB @Word "SRGB"-  colorSpaceLenientSpec @SRGB @_ @Float 0.001+  colorSpaceLenientSpec @SRGB @Float 0.001

@@ -0,0 +1,25 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+module Graphics.Color.SpaceSpec (spec) where++import Graphics.Color.Illuminant.CIE1931+import Graphics.Color.Space.Common+++instance (Elevator e, Random e) => Arbitrary (Color (CIExyY i) e) where+  arbitrary = ColorCIExy <$> arbitraryElevator <*> arbitraryElevator+++spec :: Spec+spec = do+  describe "XYZ" $ do+    colorModelSpec @(XYZ 'E) @Word "XYZ"+    colorSpaceSpec @(XYZ 'E) @Double+  describe "Alpha XYZ" $ do+    colorModelSpec @(Alpha (XYZ 'FL1)) @Word "Alpha (XYZ"+    colorSpaceSpec @(Alpha (XYZ 'FL1)) @Double+  describe "CIExyY" $ do+    colorModelSpec @(CIExyY 'D50) @Word "CIExyY"+    colorSpaceSpec @(CIExyY 'D50) @Double