<commit_before>{-# LANGUAGE OverloadedStrings #-}
module Clay.Color where

import Data.Monoid
import Data.String
import Data.Text (Text)
import Text.Printf

import qualified Data.Text as Text
import Data.Text.Read as Text

import Clay.Property
import Clay.Common

-- * Color datatype.

data Color
  = Rgba Integer Integer Integer Integer
  | Hsla Integer Integer Integer Integer
  | Other Text
  deriving Show

-- * Color constructors.

rgba, hsla :: Integer -> Integer -> Integer -> Integer -> Color

rgba = Rgba
hsla = Hsla

rgb, hsl :: Integer -> Integer -> Integer -> Color

rgb r g b = rgba r g b 255
hsl r g b = hsla r g b 255

grayish :: Integer -> Color
grayish g = rgb g g g

transparent :: Color
transparent = rgba 0 0 0 0

-- * Setting individual color components.

setR :: Integer -> Color -> Color
setR r (Rgba _ g b a) = Rgba r g b a
setR r (Hsla _ g b a) = Hsla r g b a
setR _ (Other o)      = Other o

setG :: Integer -> Color -> Color
setG g (Rgba r _ b a) = Rgba r g b a
setG g (Hsla r _ b a) = Hsla r g b a
setG _ (Other o)      = Other o

setB :: Integer -> Color -> Color
setB b (Rgba r g _ a) = Rgba r g b a
setB b (Hsla r g _ a) = Hsla r g b a
setB _ (Other o)      = Other o

setA :: Integer -> Color -> Color
setA a (Rgba r g b _) = Rgba r g b a
setA a (Hsla r g b _) = Hsla r g b a
setA _ (Other o)      = Other o

-- * Computing with colors.

(*.) :: Color -> Integer -> Color
(*.) (Rgba r g b a) i = Rgba (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a
(*.) (Hsla r g b a) i = Hsla (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a
(*.) (Other o)      _ = Other o

(+.) :: Color -> Integer -> Color
(+.) (Rgba r g b a) i = Rgba (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a
(+.) (Hsla r g b a) i = Hsla (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a
(+.) (Other o)      _ = Other o

(-.) :: Color -> Integer -> Color
(-.) (Rgba r g b a) i = Rgba (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a
(-.) (Hsla r g b a) i = Hsla (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a
(-.) (Other o)      _ = Other o

clamp :: Integer -> Integer
clamp i = max (min i 255) 0

-------------------------------------------------------------------------------

instance Val Color where
  value clr = Value $
    case clr of
      Rgba r g b 255 -> mconcat ["rgb(",  p r, ",", p g, ",", p b,            ")"]
      Rgba r g b a   -> mconcat ["rgba(", p r, ",", p g, ",", p b, ",", ah a, ")"]
      Hsla h s l 255 -> mconcat ["hsl(",  p h, ",", p s, ",", p l,            ")"]
      Hsla h s l a   -> mconcat ["hsla(", p h, ",", p s, ",", p l, ",", ah a, ")"]
      Other o        -> Plain o
    where p  = fromString . show
          ah = fromString . printf "%.4f" . (/ (256 :: Double)) . fromIntegral

instance None    Color where none    = Other "none"
instance Auto    Color where auto    = Other "auto"
instance Inherit Color where inherit = Other "inherit"

instance IsString Color where
  fromString = parse . fromString

parse :: Text -> Color
parse t =
  case Text.uncons t of
    Just ('#', cs) | Text.all isHex cs ->
      case Text.unpack cs of
        [a, b, c, d, e, f, g, h] -> rgba (hex a b) (hex c d) (hex e f) (hex g h)
        [a, b, c, d, e, f      ] -> rgb  (hex a b) (hex c d) (hex e f)
        [a, b, c, d            ] -> rgba (hex a a) (hex b b) (hex c c) (hex d d)
        [a, b, c               ] -> rgb  (hex a a) (hex b b) (hex c c)
        _                        -> err
    _                            -> err

  where
    hex a b = either err fst (Text.hexadecimal (Text.singleton a <> Text.singleton b))
    isHex a = (a >= 'a' && a <= 'f') || (a >= 'A' && a <= 'F') || (a >= '0' && a <= '9')
    err = error "Invalid color string"

-------------------------------------------------------------------------------

-- * List of color values by name.

aliceblue, antiquewhite, aqua, aquamarine, azure, beige, bisque, black,
  blanchedalmond, blue, blueviolet, brown, burlywood, cadetblue, chartreuse,<commit_msg>Added Other instance for colors.<commit_after>{-# LANGUAGE OverloadedStrings #-}
module Clay.Color where

import Data.Monoid
import Data.String
import Data.Text (Text)
import Text.Printf

import qualified Data.Text as Text
import Data.Text.Read as Text

import Clay.Property
import Clay.Common

-- * Color datatype.

data Color
  = Rgba Integer Integer Integer Integer
  | Hsla Integer Integer Integer Integer
  | Other Value
  deriving Show

-- * Color constructors.

rgba, hsla :: Integer -> Integer -> Integer -> Integer -> Color

rgba = Rgba
hsla = Hsla

rgb, hsl :: Integer -> Integer -> Integer -> Color

rgb r g b = rgba r g b 255
hsl r g b = hsla r g b 255

grayish :: Integer -> Color
grayish g = rgb g g g

transparent :: Color
transparent = rgba 0 0 0 0

-- * Setting individual color components.

setR :: Integer -> Color -> Color
setR r (Rgba _ g b a) = Rgba r g b a
setR r (Hsla _ g b a) = Hsla r g b a
setR _ (Other o)      = Other o

setG :: Integer -> Color -> Color
setG g (Rgba r _ b a) = Rgba r g b a
setG g (Hsla r _ b a) = Hsla r g b a
setG _ (Other o)      = Other o

setB :: Integer -> Color -> Color
setB b (Rgba r g _ a) = Rgba r g b a
setB b (Hsla r g _ a) = Hsla r g b a
setB _ (Other o)      = Other o

setA :: Integer -> Color -> Color
setA a (Rgba r g b _) = Rgba r g b a
setA a (Hsla r g b _) = Hsla r g b a
setA _ (Other o)      = Other o

-- * Computing with colors.

(*.) :: Color -> Integer -> Color
(*.) (Rgba r g b a) i = Rgba (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a
(*.) (Hsla r g b a) i = Hsla (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a
(*.) (Other o)      _ = Other o

(+.) :: Color -> Integer -> Color
(+.) (Rgba r g b a) i = Rgba (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a
(+.) (Hsla r g b a) i = Hsla (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a
(+.) (Other o)      _ = Other o

(-.) :: Color -> Integer -> Color
(-.) (Rgba r g b a) i = Rgba (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a
(-.) (Hsla r g b a) i = Hsla (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a
(-.) (Other o)      _ = Other o

clamp :: Integer -> Integer
clamp i = max (min i 255) 0

-------------------------------------------------------------------------------

instance Val Color where
  value clr =
    case clr of
      Rgba r g b 255 -> Value $mconcat ["rgb(",  p r, ",", p g, ",", p b,            ")"]
      Rgba r g b a   -> Value $mconcat ["rgba(", p r, ",", p g, ",", p b, ",", ah a, ")"]
      Hsla h s l 255 -> Value $mconcat ["hsl(",  p h, ",", p s, ",", p l,            ")"]
      Hsla h s l a   -> Value $mconcat ["hsla(", p h, ",", p s, ",", p l, ",", ah a, ")"]
      Other o        -> o
    where p  = fromString . show
          ah = fromString . printf "%.4f" . (/ (256 :: Double)) . fromIntegral

instance None    Color where none    = Other "none"
instance Auto    Color where auto    = Other "auto"
instance Inherit Color where inherit = Other "inherit"
instance Other   Color where other   = Other

instance IsString Color where
  fromString = parse . fromString

parse :: Text -> Color
parse t =
  case Text.uncons t of
    Just ('#', cs) | Text.all isHex cs ->
      case Text.unpack cs of
        [a, b, c, d, e, f, g, h] -> rgba (hex a b) (hex c d) (hex e f) (hex g h)
        [a, b, c, d, e, f      ] -> rgb  (hex a b) (hex c d) (hex e f)
        [a, b, c, d            ] -> rgba (hex a a) (hex b b) (hex c c) (hex d d)
        [a, b, c               ] -> rgb  (hex a a) (hex b b) (hex c c)
        _                        -> err
    _                            -> err

  where
    hex a b = either err fst (Text.hexadecimal (Text.singleton a <> Text.singleton b))
    isHex a = (a >= 'a' && a <= 'f') || (a >= 'A' && a <= 'F') || (a >= '0' && a <= '9')
    err = error "Invalid color string"

-------------------------------------------------------------------------------

-- * List of color values by name.

aliceblue, antiquewhite, aqua, aquamarine, azure, beige, bisque, black,
  blanchedalmond, blue, blueviolet, brown, burlywood, cadetblue, chartreuse,
{'fraction_non_alphanumeric': 0.19180307384730727, 'fraction_numerical': 0.006497563413719855, 'mean_word_length': 1.8708751793400287, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 83, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4466378', 'n_tokens_mistral': 3037, 'n_tokens_neox': 2955, 'n_words': 1235}