lehins / Color / 179

Committed 14 Jan 2025 06:40AM UTC coverage: 71.106%. Remained the same

Build # 179

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #18 from lehins/fix-coveralls

Make casing consistent and ensure coveralls are uploaded

Run Details

2050 of 2883 relevant lines covered (71.11%)

1.37 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

42.37

/Color/src/Graphics/Color/Model/Internal.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module      : Graphics.Color.Model.Internal
-- Copyright   : (c) Alexey Kuleshevich 2018-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Model.Internal
  ( ColorModel(..)
  , module Graphics.Color.Algebra
  , showsColorModel
  , showsColorModelOpen
  -- * Alpha
  , Alpha
  , Opaque
  , addAlpha
  , getAlpha
  , setAlpha
  , dropAlpha
  , modifyAlpha
  , modifyOpaque
  , Color(..)
  -- * Helpers
  , foldr3
  , foldr4
  , traverse3
  , traverse4
  , sizeOfN
  , alignmentN
  , peek3
  , poke3
  , peek4
  , poke4
  , VU.MVector(MV_Color)
  , VU.Vector(V_Color)
  ) where

import qualified Control.Applicative as A
import Data.List.NonEmpty as NE
import Control.DeepSeq (NFData(rnf), deepseq)
import Data.Default.Class (Default(..))
import Data.Foldable as F
import Data.Kind
import Data.Typeable
import qualified Data.Vector.Generic as V
import qualified Data.Vector.Generic.Mutable as VM
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import Foreign.Ptr
import Foreign.Storable
import GHC.TypeLits
import Graphics.Color.Algebra

-- | A Color family with a color space and a precision of elements.
data family Color cs e :: Type

class ( Functor (Color cs)
      , Applicative (Color cs)
      , Foldable (Color cs)
      , Traversable (Color cs)
      , Eq (Color cs e)
      , Show (Color cs e)
      , VU.Unbox (Components cs e)
      , VS.Storable (Color cs e)
      , Typeable cs
      , Elevator e
      , Typeable (Opaque cs)
      ) =>
      ColorModel cs e where
  type Components cs e :: Type
  type ChannelCount cs :: Nat
  -- | Convert a Color to a representation suitable for storage as an unboxed
  -- element, usually a tuple of channels.
  toComponents :: Color cs e -> Components cs e
  -- | Convert from an elemnt representation back to a Color.
  fromComponents :: Components cs e -> Color cs e

  -- | Number of channels in the color model (eg. RGB has three).
  --
  -- @since 0.4.0
  channelCount :: Proxy (Color cs e) -> Word8

  -- | Textual name for each of the channels
  --
  -- @since 0.4.0
  channelNames :: Proxy (Color cs e) -> NonEmpty String

  -- | Some non-white 8bit sRGB values for each of the channels that might or
  -- might not have some meaningful visual relation to the actual channel
  -- names. This is useful for plotting values.
  --
  -- @since 0.4.0
  channelColors :: Proxy (Color cs e) -> NonEmpty (V3 Word8)

  -- | Display the @cs@ portion of the pixel. Color itself will not be evaluated.
  --
  -- @since 0.1.0
  showsColorModelName :: Proxy (Color cs e) -> ShowS
  showsColorModelName _ = showsType (Proxy :: Proxy cs)


instance ColorModel cs e => Default (Color cs e) where
  def = pure 0
  {-# INLINE def #-}


instance ColorModel cs e => Num (Color cs e) where
  (+)         = A.liftA2 (+)
  {-# INLINE (+) #-}
  (-)         = A.liftA2 (-)
  {-# INLINE (-) #-}
  (*)         = A.liftA2 (*)
  {-# INLINE (*) #-}
  abs         = fmap abs
  {-# INLINE abs #-}
  signum      = fmap signum
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}


instance (ColorModel cs e, Fractional e) => Fractional (Color cs e) where
  (/)          = A.liftA2 (/)
  {-# INLINE (/) #-}
  recip        = fmap recip
  {-# INLINE recip #-}
  fromRational = pure . fromRational
  {-# INLINE fromRational #-}


instance (ColorModel cs e, Floating e) => Floating (Color cs e) where
  pi      = pure pi
  {-# INLINE pi #-}
  exp     = fmap exp
  {-# INLINE exp #-}
  log     = fmap log
  {-# INLINE log #-}
  sin     = fmap sin
  {-# INLINE sin #-}
  cos     = fmap cos
  {-# INLINE cos #-}
  asin    = fmap asin
  {-# INLINE asin #-}
  atan    = fmap atan
  {-# INLINE atan #-}
  acos    = fmap acos
  {-# INLINE acos #-}
  sinh    = fmap sinh
  {-# INLINE sinh #-}
  cosh    = fmap cosh
  {-# INLINE cosh #-}
  asinh   = fmap asinh
  {-# INLINE asinh #-}
  atanh   = fmap atanh
  {-# INLINE atanh #-}
  acosh   = fmap acosh
  {-# INLINE acosh #-}

instance ColorModel cs e => Bounded (Color cs e) where
  maxBound = pure maxValue
  {-# INLINE maxBound #-}
  minBound = pure minValue
  {-# INLINE minBound #-}

instance (ColorModel cs e, NFData e) => NFData (Color cs e) where
  rnf = foldr' deepseq ()
  {-# INLINE rnf #-}


-- | Unboxing of a `Color`.
instance ColorModel cs e => VU.Unbox (Color cs e)

newtype instance VU.MVector s (Color cs e) = MV_Color (VU.MVector s (Components cs e))

instance ColorModel cs e => VM.MVector VU.MVector (Color cs e) where
  basicLength (MV_Color mvec) = VM.basicLength mvec
  {-# INLINE basicLength #-}
  basicUnsafeSlice idx len (MV_Color mvec) = MV_Color (VM.basicUnsafeSlice idx len mvec)
  {-# INLINE basicUnsafeSlice #-}
  basicOverlaps (MV_Color mvec) (MV_Color mvec') = VM.basicOverlaps mvec mvec'
  {-# INLINE basicOverlaps #-}
  basicUnsafeNew len = MV_Color <$> VM.basicUnsafeNew len
  {-# INLINE basicUnsafeNew #-}
  basicUnsafeReplicate len val = MV_Color <$> VM.basicUnsafeReplicate len (toComponents val)
  {-# INLINE basicUnsafeReplicate #-}
  basicUnsafeRead (MV_Color mvec) idx = fromComponents <$> VM.basicUnsafeRead mvec idx
  {-# INLINE basicUnsafeRead #-}
  basicUnsafeWrite (MV_Color mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents val)
  {-# INLINE basicUnsafeWrite #-}
  basicClear (MV_Color mvec) = VM.basicClear mvec
  {-# INLINE basicClear #-}
  basicSet (MV_Color mvec) val = VM.basicSet mvec (toComponents val)
  {-# INLINE basicSet #-}
  basicUnsafeCopy (MV_Color mvec) (MV_Color mvec') = VM.basicUnsafeCopy mvec mvec'
  {-# INLINE basicUnsafeCopy #-}
  basicUnsafeMove (MV_Color mvec) (MV_Color mvec') = VM.basicUnsafeMove mvec mvec'
  {-# INLINE basicUnsafeMove #-}
  basicUnsafeGrow (MV_Color mvec) len = MV_Color <$> VM.basicUnsafeGrow mvec len
  {-# INLINE basicUnsafeGrow #-}
  basicInitialize (MV_Color mvec) = VM.basicInitialize mvec
  {-# INLINE basicInitialize #-}


newtype instance VU.Vector (Color cs e) = V_Color (VU.Vector (Components cs e))

instance (ColorModel cs e) => V.Vector VU.Vector (Color cs e) where
  basicUnsafeFreeze (MV_Color mvec) = V_Color <$> V.basicUnsafeFreeze mvec
  {-# INLINE basicUnsafeFreeze #-}
  basicUnsafeThaw (V_Color vec) = MV_Color <$> V.basicUnsafeThaw vec
  {-# INLINE basicUnsafeThaw #-}
  basicLength (V_Color vec) = V.basicLength vec
  {-# INLINE basicLength #-}
  basicUnsafeSlice idx len (V_Color vec) = V_Color (V.basicUnsafeSlice idx len vec)
  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeIndexM (V_Color vec) idx = fromComponents <$> V.basicUnsafeIndexM vec idx
  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeCopy (MV_Color mvec) (V_Color vec) = V.basicUnsafeCopy mvec vec
  {-# INLINE basicUnsafeCopy #-}
  elemseq (V_Color vec) val = V.elemseq vec (toComponents val)
  {-# INLINE elemseq #-}

channelSeparator :: Char
channelSeparator = ','

showsColorModel :: ColorModel cs e => Color cs e -> ShowS
showsColorModel px = ('<' :) . showsColorModelOpen px . ('>' :)

showsColorModelOpen :: ColorModel cs e => Color cs e -> ShowS
showsColorModelOpen px = t . (":(" ++) . channels . (')' :)
  where
    t = asProxy px showsColorModelName
    channels =
      case F.toList px of
        [] -> id
        (x:xs) -> foldl' (\facc y -> facc . (channelSeparator :) . toShowS y) (toShowS x) xs

-- TODO: consolidate those helpers into algebra by means of: V2, V3, V4 and V5.
-- Foldable helpers.

foldr3 :: (e -> a -> a) -> a -> e -> e -> e -> a
foldr3 f acc c0 c1 c2 = f c0 (f c1 (f c2 acc))
{-# INLINE foldr3 #-}

foldr4 :: (e -> a -> a) -> a -> e -> e -> e -> e -> a
foldr4 f acc c0 c1 c2 c3 = f c0 (f c1 (f c2 (f c3 acc)))
{-# INLINE foldr4 #-}

traverse3 :: Applicative f => (a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> f b
traverse3 g f c0 c1 c2 = g <$> f c0 <*> f c1 <*> f c2
{-# INLINE traverse3 #-}

traverse4 :: Applicative f => (a -> a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> t -> f b
traverse4 g f c0 c1 c2 c3 = g <$> f c0 <*> f c1 <*> f c2 <*> f c3
{-# INLINE traverse4 #-}

-- Storable helpers

sizeOfN :: forall cs e . Storable e => Int -> Color cs e -> Int
sizeOfN n _ = n * sizeOf (undefined :: e)
{-# INLINE sizeOfN #-}

alignmentN :: forall cs e . Storable e => Int -> Color cs e -> Int
alignmentN _ _ = alignment (undefined :: e)
{-# INLINE alignmentN #-}

peek3 :: Storable e => (e -> e -> e -> Color cs e) -> Ptr (Color cs e) -> IO (Color cs e)
peek3 f p = do
  let q = castPtr p
  c0 <- peek q
  c1 <- peekElemOff q 1
  c2 <- peekElemOff q 2
  return $! f c0 c1 c2
{-# INLINE peek3 #-}

poke3 :: Storable e => Ptr (Color cs e) -> e -> e -> e -> IO ()
poke3 p c0 c1 c2 = do
  let q = castPtr p
  poke q c0
  pokeElemOff q 1 c1
  pokeElemOff q 2 c2
{-# INLINE poke3 #-}

peek4 ::
     forall cs e. Storable e
  => (e -> e -> e -> e -> Color cs e)
  -> Ptr (Color cs e)
  -> IO (Color cs e)
peek4 f p = do
  c0 <- peek (castPtr p)
  peek3 (f c0) (p `plusPtr` sizeOf (undefined :: e))
{-# INLINE peek4 #-}

poke4 :: forall cs e . Storable e => Ptr (Color cs e) -> e -> e -> e -> e -> IO ()
poke4 p c0 c1 c2 c3 = do
  poke (castPtr p) c0
  poke3 (p `plusPtr` sizeOf (undefined :: e)) c1 c2 c3
{-# INLINE poke4 #-}


-----------
-- Alpha --
-----------



data Alpha cs

data instance Color (Alpha cs) e = Alpha
  { _opaque :: !(Color cs e)
  , _alpha :: !e
  }

-- | Get the alpha channel value for the pixel
--
-- @since 0.1.0
getAlpha :: Color (Alpha cs) e -> e
getAlpha = _alpha
{-# INLINE getAlpha #-}

-- | Get the opaque pixel value, while leaving alpha channel intact.
--
-- @since 0.1.0
dropAlpha :: Color (Alpha cs) e -> Color cs e
dropAlpha = _opaque
{-# INLINE dropAlpha #-}

-- | Add an alpha channel value to an opaque pixel
--
-- @since 0.1.0
addAlpha :: Color cs e -> e -> Color (Alpha cs) e
addAlpha = Alpha
{-# INLINE addAlpha #-}

-- | Change the alpha channel value for the pixel
--
-- @since 0.1.0
setAlpha :: Color (Alpha cs) e -> e -> Color (Alpha cs) e
setAlpha px a = px { _alpha = a }
{-# INLINE setAlpha #-}

-- | Change the alpha channel value for the pixel
--
-- @since 0.1.0
modifyAlpha :: (e -> e) -> Color (Alpha cs) e -> Color (Alpha cs) e
modifyAlpha f px = px { _alpha = f (_alpha px) }
{-# INLINE modifyAlpha #-}

-- | Change the opaque pixel value, while leaving alpha channel intact.
--
-- @since 0.1.0
modifyOpaque :: (Color cs e -> Color cs' e) -> Color (Alpha cs) e -> Color (Alpha cs') e
modifyOpaque fpx pxa = pxa { _opaque = fpx (_opaque pxa) }
{-# INLINE modifyOpaque #-}

instance (Eq (Color cs e), Eq e) => Eq (Color (Alpha cs) e) where
  (==) (Alpha px1 a1) (Alpha px2 a2) = px1 == px2 && a1 == a2
  {-# INLINE (==) #-}

instance (ColorModel cs e, cs ~ Opaque (Alpha 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, cs ~ Opaque (Alpha cs)) =>
         ColorModel (Alpha cs) e where
  type Components (Alpha cs) e = (Components cs e, e)
  type ChannelCount (Alpha cs) = 1 + ChannelCount cs
  channelCount _ = 1 + channelCount (Proxy :: Proxy (Color cs e))
  {-# INLINE channelCount #-}
  channelNames _ = channelNames (Proxy :: Proxy (Color cs e)) <> ("Alpha" :| [])
  channelColors _ =
    channelColors (Proxy :: Proxy (Color cs e)) <> (V3 0xe6 0xe6 0xfa :| []) -- <- lavander
  toComponents (Alpha px a) = (toComponents px, a)
  {-# INLINE toComponents #-}
  fromComponents (pxc, a) = Alpha (fromComponents pxc) a
  {-# INLINE fromComponents #-}
  showsColorModelName _ = ("Alpha (" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) . (')':)


instance Functor (Color cs) => Functor (Color (Alpha cs)) where
  fmap f (Alpha px a) = Alpha (fmap f px) (f a)
  {-# INLINE fmap #-}

instance Applicative (Color cs) => Applicative (Color (Alpha cs)) where
  pure e = Alpha (pure e) e
  {-# INLINE pure #-}
  (Alpha fpx fa) <*> (Alpha px a) = Alpha (fpx <*> px) (fa a)
  {-# INLINE (<*>) #-}

instance Foldable (Color cs) => Foldable (Color (Alpha cs)) where
  foldr f acc (Alpha px a) = foldr f (f a acc) px
  {-# INLINE foldr #-}
  foldr1 f (Alpha px a) = foldr f a px
  {-# INLINE foldr1 #-}

instance Traversable (Color cs) => Traversable (Color (Alpha cs)) where
  traverse f (Alpha px a) = Alpha <$> traverse f px <*> f a
  {-# INLINE traverse #-}

instance (Storable (Color cs e), Storable e) => Storable (Color (Alpha cs) e) where
  sizeOf _ = sizeOf (undefined :: Color cs e) + sizeOf (undefined :: e)
  {-# INLINE sizeOf #-}
  alignment _ = alignment (undefined :: e)
  {-# INLINE alignment #-}
  peek ptr = do
    px <- peek (castPtr ptr)
    Alpha px <$> peekByteOff ptr (sizeOf px)
  {-# INLINE peek #-}
  poke ptr (Alpha px a) = do
    poke (castPtr ptr) px
    pokeByteOff ptr (sizeOf px) a
  {-# INLINE poke #-}

1	{-# LANGUAGE DataKinds #-}
2	{-# LANGUAGE FlexibleContexts #-}
3	{-# LANGUAGE FlexibleInstances #-}
4	{-# LANGUAGE MultiParamTypeClasses #-}
5	{-# LANGUAGE ScopedTypeVariables #-}
6	{-# LANGUAGE TypeFamilies #-}
7	{-# LANGUAGE TypeOperators #-}
8	{-# LANGUAGE UndecidableInstances #-}
9	-- \|
10	-- Module : Graphics.Color.Model.Internal
11	-- Copyright : (c) Alexey Kuleshevich 2018-2025
12	-- License : BSD3
13	-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>
14	-- Stability : experimental
15	-- Portability : non-portable
16	--
17	module Graphics.Color.Model.Internal
18	( ColorModel(..)
19	, module Graphics.Color.Algebra
20	, showsColorModel
21	, showsColorModelOpen
22	-- * Alpha
23	, Alpha
24	, Opaque
25	, addAlpha
26	, getAlpha
27	, setAlpha
28	, dropAlpha
29	, modifyAlpha
30	, modifyOpaque
31	, Color(..)
32	-- * Helpers
33	, foldr3
34	, foldr4
35	, traverse3
36	, traverse4
37	, sizeOfN
38	, alignmentN
39	, peek3
40	, poke3
41	, peek4
42	, poke4
43	, VU.MVector(MV_Color)
44	, VU.Vector(V_Color)
45	) where
46
47	import qualified Control.Applicative as A
48	import Data.List.NonEmpty as NE
49	import Control.DeepSeq (NFData(rnf), deepseq)
50	import Data.Default.Class (Default(..))
51	import Data.Foldable as F
52	import Data.Kind
53	import Data.Typeable
54	import qualified Data.Vector.Generic as V
55	import qualified Data.Vector.Generic.Mutable as VM
56	import qualified Data.Vector.Storable as VS
57	import qualified Data.Vector.Unboxed as VU
58	import Foreign.Ptr
59	import Foreign.Storable
60	import GHC.TypeLits
61	import Graphics.Color.Algebra
62
63	-- \| A Color family with a color space and a precision of elements.
64	data family Color cs e :: Type
65
66	class ( Functor (Color cs)
67	, Applicative (Color cs)
68	, Foldable (Color cs)
69	, Traversable (Color cs)
70	, Eq (Color cs e)
71	, Show (Color cs e)
72	, VU.Unbox (Components cs e)
73	, VS.Storable (Color cs e)
74	, Typeable cs
75	, Elevator e
76	, Typeable (Opaque cs)
77	) =>
78	ColorModel cs e where
79	type Components cs e :: Type
80	type ChannelCount cs :: Nat
81	-- \| Convert a Color to a representation suitable for storage as an unboxed
82	-- element, usually a tuple of channels.
83	toComponents :: Color cs e -> Components cs e
84	-- \| Convert from an elemnt representation back to a Color.
85	fromComponents :: Components cs e -> Color cs e
86
87	-- \| Number of channels in the color model (eg. RGB has three).
88	--
89	-- @since 0.4.0
90	channelCount :: Proxy (Color cs e) -> Word8
91
92	-- \| Textual name for each of the channels
93	--
94	-- @since 0.4.0
95	channelNames :: Proxy (Color cs e) -> NonEmpty String
96
97	-- \| Some non-white 8bit sRGB values for each of the channels that might or
98	-- might not have some meaningful visual relation to the actual channel
99	-- names. This is useful for plotting values.
100	--
101	-- @since 0.4.0
102	channelColors :: Proxy (Color cs e) -> NonEmpty (V3 Word8)
103
104	-- \| Display the @cs@ portion of the pixel. Color itself will not be evaluated.
105	--
106	-- @since 0.1.0
107	showsColorModelName :: Proxy (Color cs e) -> ShowS
108	showsColorModelName _ = showsType (Proxy :: Proxy cs)	1✔
109
110
111	instance ColorModel cs e => Default (Color cs e) where
112	def = pure 0	×
113	{-# INLINE def #-}
114
115
116	instance ColorModel cs e => Num (Color cs e) where	×
117	(+) = A.liftA2 (+)	×
118	{-# INLINE (+) #-}
119	(-) = A.liftA2 (-)	×
120	{-# INLINE (-) #-}
121	() = A.liftA2 ()	×
122	{-# INLINE (*) #-}
123	abs = fmap abs	×
124	{-# INLINE abs #-}
125	signum = fmap signum	×
126	{-# INLINE signum #-}
127	fromInteger = pure . fromInteger	×
128	{-# INLINE fromInteger #-}
129
130
131	instance (ColorModel cs e, Fractional e) => Fractional (Color cs e) where
132	(/) = A.liftA2 (/)	×
133	{-# INLINE (/) #-}
134	recip = fmap recip	×
135	{-# INLINE recip #-}
136	fromRational = pure . fromRational	×
137	{-# INLINE fromRational #-}
138
139
140	instance (ColorModel cs e, Floating e) => Floating (Color cs e) where	×
141	pi = pure pi	×
142	{-# INLINE pi #-}
143	exp = fmap exp	×
144	{-# INLINE exp #-}
145	log = fmap log	×
146	{-# INLINE log #-}
147	sin = fmap sin	×
148	{-# INLINE sin #-}
149	cos = fmap cos	×
150	{-# INLINE cos #-}
151	asin = fmap asin	×
152	{-# INLINE asin #-}
153	atan = fmap atan	×
154	{-# INLINE atan #-}
155	acos = fmap acos	×
156	{-# INLINE acos #-}
157	sinh = fmap sinh	×
158	{-# INLINE sinh #-}
159	cosh = fmap cosh	×
160	{-# INLINE cosh #-}
161	asinh = fmap asinh	×
162	{-# INLINE asinh #-}
163	atanh = fmap atanh	×
164	{-# INLINE atanh #-}
165	acosh = fmap acosh	×
166	{-# INLINE acosh #-}
167
168	instance ColorModel cs e => Bounded (Color cs e) where
169	maxBound = pure maxValue	×
170	{-# INLINE maxBound #-}
171	minBound = pure minValue	×
172	{-# INLINE minBound #-}
173
174	instance (ColorModel cs e, NFData e) => NFData (Color cs e) where
175	rnf = foldr' deepseq ()	×
176	{-# INLINE rnf #-}
177
178
179	-- \| Unboxing of a `Color`.
180	instance ColorModel cs e => VU.Unbox (Color cs e)
181
182	newtype instance VU.MVector s (Color cs e) = MV_Color (VU.MVector s (Components cs e))
183
184	instance ColorModel cs e => VM.MVector VU.MVector (Color cs e) where
185	basicLength (MV_Color mvec) = VM.basicLength mvec	×
186	{-# INLINE basicLength #-}
187	basicUnsafeSlice idx len (MV_Color mvec) = MV_Color (VM.basicUnsafeSlice idx len mvec)	2✔
188	{-# INLINE basicUnsafeSlice #-}
189	basicOverlaps (MV_Color mvec) (MV_Color mvec') = VM.basicOverlaps mvec mvec'	×
190	{-# INLINE basicOverlaps #-}
191	basicUnsafeNew len = MV_Color <$> VM.basicUnsafeNew len	2✔
192	{-# INLINE basicUnsafeNew #-}
193	basicUnsafeReplicate len val = MV_Color <$> VM.basicUnsafeReplicate len (toComponents val)	×
194	{-# INLINE basicUnsafeReplicate #-}
195	basicUnsafeRead (MV_Color mvec) idx = fromComponents <$> VM.basicUnsafeRead mvec idx	2✔
196	{-# INLINE basicUnsafeRead #-}
197	basicUnsafeWrite (MV_Color mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents val)	2✔
198	{-# INLINE basicUnsafeWrite #-}
199	basicClear (MV_Color mvec) = VM.basicClear mvec	×
200	{-# INLINE basicClear #-}
201	basicSet (MV_Color mvec) val = VM.basicSet mvec (toComponents val)	×
202	{-# INLINE basicSet #-}
203	basicUnsafeCopy (MV_Color mvec) (MV_Color mvec') = VM.basicUnsafeCopy mvec mvec'	2✔
204	{-# INLINE basicUnsafeCopy #-}
205	basicUnsafeMove (MV_Color mvec) (MV_Color mvec') = VM.basicUnsafeMove mvec mvec'	×
206	{-# INLINE basicUnsafeMove #-}
207	basicUnsafeGrow (MV_Color mvec) len = MV_Color <$> VM.basicUnsafeGrow mvec len	2✔
208	{-# INLINE basicUnsafeGrow #-}
209	basicInitialize (MV_Color mvec) = VM.basicInitialize mvec	×
210	{-# INLINE basicInitialize #-}
211
212
213	newtype instance VU.Vector (Color cs e) = V_Color (VU.Vector (Components cs e))
214
215	instance (ColorModel cs e) => V.Vector VU.Vector (Color cs e) where
216	basicUnsafeFreeze (MV_Color mvec) = V_Color <$> V.basicUnsafeFreeze mvec	2✔
217	{-# INLINE basicUnsafeFreeze #-}
218	basicUnsafeThaw (V_Color vec) = MV_Color <$> V.basicUnsafeThaw vec	×
219	{-# INLINE basicUnsafeThaw #-}
220	basicLength (V_Color vec) = V.basicLength vec	×
221	{-# INLINE basicLength #-}
222	basicUnsafeSlice idx len (V_Color vec) = V_Color (V.basicUnsafeSlice idx len vec)	×
223	{-# INLINE basicUnsafeSlice #-}
224	basicUnsafeIndexM (V_Color vec) idx = fromComponents <$> V.basicUnsafeIndexM vec idx	2✔
225	{-# INLINE basicUnsafeIndexM #-}
226	basicUnsafeCopy (MV_Color mvec) (V_Color vec) = V.basicUnsafeCopy mvec vec	×
227	{-# INLINE basicUnsafeCopy #-}
228	elemseq (V_Color vec) val = V.elemseq vec (toComponents val)	×
229	{-# INLINE elemseq #-}
230
231	channelSeparator :: Char
232	channelSeparator = ','	×
233
234	showsColorModel :: ColorModel cs e => Color cs e -> ShowS
235	showsColorModel px = ('<' :) . showsColorModelOpen px . ('>' :)	×
236
237	showsColorModelOpen :: ColorModel cs e => Color cs e -> ShowS
238	showsColorModelOpen px = t . (":(" ++) . channels . (')' :)	×
239	where
240	t = asProxy px showsColorModelName	×
241	channels =	×
242	case F.toList px of	×
243	[] -> id	×
244	(x:xs) -> foldl' (\facc y -> facc . (channelSeparator :) . toShowS y) (toShowS x) xs	×
245
246	-- TODO: consolidate those helpers into algebra by means of: V2, V3, V4 and V5.
247	-- Foldable helpers.
248
249	foldr3 :: (e -> a -> a) -> a -> e -> e -> e -> a
250	foldr3 f acc c0 c1 c2 = f c0 (f c1 (f c2 acc))	×
251	{-# INLINE foldr3 #-}
252
253	foldr4 :: (e -> a -> a) -> a -> e -> e -> e -> e -> a
254	foldr4 f acc c0 c1 c2 c3 = f c0 (f c1 (f c2 (f c3 acc)))	×
255	{-# INLINE foldr4 #-}
256
257	traverse3 :: Applicative f => (a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> f b
258	traverse3 g f c0 c1 c2 = g <$> f c0 <> f c1 <> f c2	×
259	{-# INLINE traverse3 #-}
260
261	traverse4 :: Applicative f => (a -> a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> t -> f b
262	traverse4 g f c0 c1 c2 c3 = g <$> f c0 <> f c1 <> f c2 <*> f c3	×
263	{-# INLINE traverse4 #-}
264
265	-- Storable helpers
266
267	sizeOfN :: forall cs e . Storable e => Int -> Color cs e -> Int
268	sizeOfN n _ = n * sizeOf (undefined :: e)	1✔
269	{-# INLINE sizeOfN #-}
270
271	alignmentN :: forall cs e . Storable e => Int -> Color cs e -> Int
272	alignmentN _ _ = alignment (undefined :: e)	1✔
273	{-# INLINE alignmentN #-}
274
275	peek3 :: Storable e => (e -> e -> e -> Color cs e) -> Ptr (Color cs e) -> IO (Color cs e)
276	peek3 f p = do	2✔
277	let q = castPtr p	2✔
278	c0 <- peek q	2✔
279	c1 <- peekElemOff q 1	2✔
280	c2 <- peekElemOff q 2	2✔
281	return $! f c0 c1 c2	2✔
282	{-# INLINE peek3 #-}
283
284	poke3 :: Storable e => Ptr (Color cs e) -> e -> e -> e -> IO ()
285	poke3 p c0 c1 c2 = do	2✔
286	let q = castPtr p	2✔
287	poke q c0	2✔
288	pokeElemOff q 1 c1	2✔
289	pokeElemOff q 2 c2	2✔
290	{-# INLINE poke3 #-}
291
292	peek4 ::
293	forall cs e. Storable e
294	=> (e -> e -> e -> e -> Color cs e)
295	-> Ptr (Color cs e)
296	-> IO (Color cs e)
297	peek4 f p = do	2✔
298	c0 <- peek (castPtr p)	2✔
299	peek3 (f c0) (p `plusPtr` sizeOf (undefined :: e))	1✔
300	{-# INLINE peek4 #-}
301
302	poke4 :: forall cs e . Storable e => Ptr (Color cs e) -> e -> e -> e -> e -> IO ()
303	poke4 p c0 c1 c2 c3 = do	2✔
304	poke (castPtr p) c0	2✔
305	poke3 (p `plusPtr` sizeOf (undefined :: e)) c1 c2 c3	1✔
306	{-# INLINE poke4 #-}
307
308
309	-----------
310	-- Alpha --
311	-----------
312
313
314
315	data Alpha cs
316
317	data instance Color (Alpha cs) e = Alpha
318	{ _opaque :: !(Color cs e)	2✔
319	, _alpha :: !e	×
320	}
321
322	-- \| Get the alpha channel value for the pixel
323	--
324	-- @since 0.1.0
325	getAlpha :: Color (Alpha cs) e -> e
326	getAlpha = _alpha	×
327	{-# INLINE getAlpha #-}
328
329	-- \| Get the opaque pixel value, while leaving alpha channel intact.
330	--
331	-- @since 0.1.0
332	dropAlpha :: Color (Alpha cs) e -> Color cs e
333	dropAlpha = _opaque	2✔
334	{-# INLINE dropAlpha #-}
335
336	-- \| Add an alpha channel value to an opaque pixel
337	--
338	-- @since 0.1.0
339	addAlpha :: Color cs e -> e -> Color (Alpha cs) e
340	addAlpha = Alpha	2✔
341	{-# INLINE addAlpha #-}
342
343	-- \| Change the alpha channel value for the pixel
344	--
345	-- @since 0.1.0
346	setAlpha :: Color (Alpha cs) e -> e -> Color (Alpha cs) e
347	setAlpha px a = px { _alpha = a }	×
348	{-# INLINE setAlpha #-}
349
350	-- \| Change the alpha channel value for the pixel
351	--
352	-- @since 0.1.0
353	modifyAlpha :: (e -> e) -> Color (Alpha cs) e -> Color (Alpha cs) e
354	modifyAlpha f px = px { _alpha = f (_alpha px) }	×
355	{-# INLINE modifyAlpha #-}
356
357	-- \| Change the opaque pixel value, while leaving alpha channel intact.
358	--
359	-- @since 0.1.0
360	modifyOpaque :: (Color cs e -> Color cs' e) -> Color (Alpha cs) e -> Color (Alpha cs') e
361	modifyOpaque fpx pxa = pxa { _opaque = fpx (_opaque pxa) }	2✔
362	{-# INLINE modifyOpaque #-}
363
364	instance (Eq (Color cs e), Eq e) => Eq (Color (Alpha cs) e) where	×
365	(==) (Alpha px1 a1) (Alpha px2 a2) = px1 == px2 && a1 == a2	2✔
366	{-# INLINE (==) #-}
367
368	instance (ColorModel cs e, cs ~ Opaque (Alpha cs)) =>	×
369	Show (Color (Alpha cs) e) where
370	showsPrec _ = showsColorModel	×
371
372	type family Opaque cs where
373	Opaque (Alpha (Alpha cs)) = TypeError ('Text "Nested alpha channels are not allowed")
374	Opaque (Alpha cs) = cs
375	Opaque cs = cs
376
377	instance (ColorModel cs e, cs ~ Opaque (Alpha cs)) =>
378	ColorModel (Alpha cs) e where
379	type Components (Alpha cs) e = (Components cs e, e)
380	type ChannelCount (Alpha cs) = 1 + ChannelCount cs
381	channelCount _ = 1 + channelCount (Proxy :: Proxy (Color cs e))	1✔
382	{-# INLINE channelCount #-}
383	channelNames _ = channelNames (Proxy :: Proxy (Color cs e)) <> ("Alpha" :\| [])	1✔
384	channelColors _ =	2✔
385	channelColors (Proxy :: Proxy (Color cs e)) <> (V3 0xe6 0xe6 0xfa :\| []) -- <- lavander	1✔
386	toComponents (Alpha px a) = (toComponents px, a)	2✔
387	{-# INLINE toComponents #-}
388	fromComponents (pxc, a) = Alpha (fromComponents pxc) a	2✔
389	{-# INLINE fromComponents #-}
390	showsColorModelName _ = ("Alpha (" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) . (')':)	1✔
391
392
393	instance Functor (Color cs) => Functor (Color (Alpha cs)) where	×
394	fmap f (Alpha px a) = Alpha (fmap f px) (f a)	×
395	{-# INLINE fmap #-}
396
397	instance Applicative (Color cs) => Applicative (Color (Alpha cs)) where	×
398	pure e = Alpha (pure e) e	×
399	{-# INLINE pure #-}
400	(Alpha fpx fa) <> (Alpha px a) = Alpha (fpx <> px) (fa a)	×
401	{-# INLINE (<*>) #-}
402
403	instance Foldable (Color cs) => Foldable (Color (Alpha cs)) where	×
404	foldr f acc (Alpha px a) = foldr f (f a acc) px	1✔
405	{-# INLINE foldr #-}
406	foldr1 f (Alpha px a) = foldr f a px	×
407	{-# INLINE foldr1 #-}
408
409	instance Traversable (Color cs) => Traversable (Color (Alpha cs)) where	×
410	traverse f (Alpha px a) = Alpha <$> traverse f px <*> f a	×
411	{-# INLINE traverse #-}
412
413	instance (Storable (Color cs e), Storable e) => Storable (Color (Alpha cs) e) where	2✔
414	sizeOf _ = sizeOf (undefined :: Color cs e) + sizeOf (undefined :: e)	1✔
415	{-# INLINE sizeOf #-}
416	alignment _ = alignment (undefined :: e)	1✔
417	{-# INLINE alignment #-}
418	peek ptr = do	2✔
419	px <- peek (castPtr ptr)	2✔
420	Alpha px <$> peekByteOff ptr (sizeOf px)	1✔
421	{-# INLINE peek #-}
422	poke ptr (Alpha px a) = do	2✔
423	poke (castPtr ptr) px	2✔
424	pokeByteOff ptr (sizeOf px) a	1✔
425	{-# INLINE poke #-}

lehins / Color / 179

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous