-- |
-- Module:     Data.CSS.Types
-- Copyright:  (c) 2013 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>

{-# LANGUAGE IncoherentInstances #-}

module Data.CSS.Types
    ( -- * Style sheets
      CSS(..), cssImports, cssProps,
      Property(..), propName, propSelector, propValue, propImportant,
      -- ** CSS building
      BuildCfg(..), bcMedia, bcSelector,
      SetProp,
      SetPropM,
      -- ** Auxiliary types
      MediaType(..), mediaTypeStr,
      PropName(..), propNameStr,
      PropValue(..), propValueStr,
      Selector(..), selectorStr,

      -- * Type classes
      ToPropValue(..)
    )
    where

import qualified Data.ByteString.Char8 as Bc
import qualified Data.ByteString.Lazy as Bl
import qualified Data.ByteString.UTF8 as Bu
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as Tl
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char8 as Blaze
import Control.Lens.TH
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Data.Bits
import Data.ByteString (ByteString)
import Data.Char
import Data.Colour
import Data.Colour.SRGB
import Data.Colour.SRGB.Linear
import Data.CSS.Utils
import Data.Data
import Data.Int
import Data.Map (Map)
import Data.Monoid
import Data.Ratio
import Data.Set (Set)
import Data.String
import Data.Text (Text)
import Data.Word


-- | Types that feature a conversion function to 'PropValue'.

class ToPropValue a where
    toPropBuilder :: a -> Builder
    toPropBuilder = fromByteString . _propValueStr . toPropValue

    toPropValue :: a -> PropValue
    toPropValue = PropValue . toByteString . toPropBuilder

instance ToPropValue Double      where toPropBuilder = showReal
instance ToPropValue Float  where toPropBuilder = showReal
instance ToPropValue Int    where toPropBuilder = showReal
instance ToPropValue Int8   where toPropBuilder = showReal
instance ToPropValue Int16  where toPropBuilder = showReal
instance ToPropValue Int32  where toPropBuilder = showReal
instance ToPropValue Int64  where toPropBuilder = showReal
instance ToPropValue Integer      where toPropBuilder = showReal
instance ToPropValue Word   where toPropBuilder = showReal
instance ToPropValue Word8  where toPropBuilder = showReal
instance ToPropValue Word16 where toPropBuilder = showReal
instance ToPropValue Word32 where toPropBuilder = showReal
instance ToPropValue Word64 where toPropBuilder = showReal
instance (Integral a) => ToPropValue (Ratio a) where toPropBuilder = showReal

instance ToPropValue ByteString    where toPropValue = PropValue
instance ToPropValue Bl.ByteString where toPropValue = PropValue . Bl.toStrict
instance ToPropValue Char          where toPropValue = PropValue . Bu.fromString . return
instance ToPropValue [Char]        where toPropValue = PropValue . Bu.fromString
instance ToPropValue Text          where toPropValue = PropValue . T.encodeUtf8
instance ToPropValue Tl.Text       where toPropValue = PropValue . T.encodeUtf8 . Tl.toStrict

instance (Floating a, RealFrac a) => ToPropValue (AlphaColour a) where
    toPropBuilder col
        | t >= 1     = toPropBuilder col'
        | t <= 0     = fromByteString "rgba(0,0,0,0)"
        | otherwise =
            fromByteString "rgba(" <>
            Blaze.fromString (show r) <> fromChar ',' <>
            Blaze.fromString (show g) <> fromChar ',' <>
            Blaze.fromString (show b) <> fromChar ',' <>
            showReal t <> fromChar ')'

        where
        t = alphaChannel col
        RGB r' g' b' = fmap (/ t) . toRGB $ col `over` black
        col'         = rgb r' g' b'
        RGB r g b    = toSRGB24 col'

instance (Floating a, RealFrac a) => ToPropValue (Colour a) where
    toPropBuilder col =
        fromChar '#' <>
        maybe (colorHex r <> colorHex g <> colorHex b) id
              (fmap mconcat $ mapM colorShortHex [r, g, b])

        where
        RGB r g b = toSRGB24 col

instance (ToPropValue a) => ToPropValue [a] where
    toPropValue =
        PropValue .
        Bc.intercalate " " .
        map (_propValueStr . toPropValue)

instance (ToPropValue a, ToPropValue b) => ToPropValue (a, b) where
    toPropBuilder (a, b) =
        toPropBuilder a <> fromChar ' ' <> toPropBuilder b

instance (ToPropValue a, ToPropValue b, ToPropValue c) => ToPropValue (a, b, c) where
    toPropBuilder (a, b, c) =
        toPropBuilder a <> fromChar ' ' <>
        toPropBuilder b <> fromChar ' ' <>
        toPropBuilder c


-- | CSS builder configuration.

data BuildCfg =
    BuildCfg {
      _bcMedia    :: Set MediaType,  -- ^ Current media type.
      _bcSelector :: [Selector]      -- ^ Current selector.
    }
    deriving (Data, Eq, Ord, Read, Show, Typeable)


-- | Cascading style sheets.

data CSS =
    CSS {
      _cssImports :: Map Text (Set MediaType),       -- ^ External stylesheets (url, media-type).
      _cssProps   :: Map (Set MediaType) [Property]  -- ^ Properties.
    }
    deriving (Data, Eq, Ord, Read, Show, Typeable)

instance Monoid CSS where
    mempty = CSS M.empty M.empty

    mappend (CSS is1 ps1) (CSS is2 ps2) =
        CSS (M.unionWith S.union is1 is2) (M.unionWith (++) ps1 ps2)


-- | Media types, e.g. @all@ or @print@.

newtype MediaType = MediaType { _mediaTypeStr :: ByteString }
    deriving (Data, Eq, Ord, Read, Show, Typeable)

instance IsString MediaType where
    fromString = MediaType . Bu.fromString


-- | Style properties.

data Property =
    Property {
      _propSelector  :: [Selector],  -- ^ Selector for this property.
      _propName      :: PropName,    -- ^ Property name.
      _propValue     :: PropValue,   -- ^ Property value.
      _propImportant :: Bool         -- ^ @!important@ property?
    }
    deriving (Data, Eq, Ord, Read, Show, Typeable)


-- | Property names, e.g. @font-family@.

newtype PropName = PropName { _propNameStr :: ByteString }
    deriving (Data, Eq, Ord, Read, Show, Typeable)

instance IsString PropName where
    fromString = PropName . Bu.fromString


-- | Property values, e.g. @sans-serif@.

newtype PropValue = PropValue { _propValueStr :: ByteString }
    deriving (Data, Eq, Ord, Read, Show, Typeable)

instance IsString PropValue where
    fromString = PropValue . Bu.fromString

instance ToPropValue PropValue where
    toPropValue = id


-- | Selectors, e.g. @*@ or @#content p@.

newtype Selector = Selector { _selectorStr :: ByteString }
    deriving (Data, Eq, Ord, Read, Show, Typeable)

instance IsString Selector where
    fromString = Selector . Bu.fromString


-- | Property setter.

type SetProp = forall m. SetPropM m


-- | Parametric property setter.

type SetPropM m = (MonadReader BuildCfg m, MonadWriter CSS m) => m ()


-- | Convert the given color byte to its hex representation.

colorHex :: Word8 -> Builder
colorHex x =
    fromChar (intToDigit (fromIntegral $ shiftR x 4)) <>
    fromChar (intToDigit (fromIntegral $ x .&. 0x0F))


-- | Convert the given color byte to its short hex representation if
-- available.

colorShortHex :: Word8 -> Maybe Builder
colorShortHex x
    | hi == lo   = Just (fromChar (intToDigit (fromIntegral lo)))
    | otherwise = Nothing
    where
    hi = shiftR x 4
    lo = x .&. 0x0F


makeLenses ''BuildCfg
makeLenses ''CSS
makeLenses ''MediaType
makeLenses ''Property
makeLenses ''PropName
makeLenses ''PropValue
makeLenses ''Selector