{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Graphics.Color.Space.RGB.Alternative.HSL
( pattern ColorHSL
, pattern ColorHSLA
, pattern ColorH360SL
, HSL
, Color(HSL)
, module Graphics.Color.Space
) where
import Data.Coerce
import Data.Proxy
import Foreign.Storable
import qualified Graphics.Color.Model.HSL as CM
import Graphics.Color.Model.Internal
import Graphics.Color.Space
data HSL cs
newtype instance Color (HSL cs) e = HSL (Color CM.HSL e)
deriving instance Eq e => Eq (Color (HSL cs) e)
deriving instance Ord e => Ord (Color (HSL cs) e)
deriving instance Functor (Color (HSL cs))
deriving instance Applicative (Color (HSL cs))
deriving instance Foldable (Color (HSL cs))
deriving instance Traversable (Color (HSL cs))
deriving instance Storable e => Storable (Color (HSL cs) e)
instance ColorModel cs e => Show (Color (HSL cs) e) where
showsPrec _ = showsColorModel
pattern ColorHSL :: e -> e -> e -> Color (HSL cs) e
pattern ColorHSL h s i = HSL (CM.ColorHSL h s i)
{-# COMPLETE ColorHSL #-}
pattern ColorHSLA :: e -> e -> e -> e -> Color (Alpha (HSL cs)) e
pattern ColorHSLA h s i a = Alpha (HSL (CM.ColorHSL h s i)) a
{-# COMPLETE ColorHSLA #-}
pattern ColorH360SL :: Fractional e => e -> e -> e -> Color (HSL cs) e
pattern ColorH360SL h s i <- ColorHSL ((* 360) -> h) s i where
ColorH360SL h s i = ColorHSL (h / 360) s i
{-# COMPLETE ColorH360SL #-}
instance ColorModel cs e => ColorModel (HSL cs) e where
type Components (HSL cs) e = (e, e, e)
toComponents = toComponents . coerce
{-# INLINE toComponents #-}
fromComponents = coerce . fromComponents
{-# INLINE fromComponents #-}
showsColorModelName _ = ("HSL-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e))
instance (ColorSpace (cs l) i e, RedGreenBlue cs i) => ColorSpace (HSL (cs l)) i e where
type BaseModel (HSL (cs l)) = CM.HSL
type BaseSpace (HSL (cs l)) = cs l
toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsl2rgb . fmap toDouble . coerce
{-# INLINE toBaseSpace #-}
fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsl . fmap toDouble . unColorRGB
{-# INLINE fromBaseSpace #-}
luminance = luminance . toBaseSpace
{-# INLINE luminance #-}