module Data.CSS.Types
(
CSS(..), cssImports, cssProps,
Property(..), propName, propSelector, propValue, propImportant,
BuildCfg(..), bcMedia, bcSelector,
SetProp,
SetPropM,
MediaType(..), mediaTypeStr,
PropName(..), propNameStr,
PropValue(..), propValueStr,
Selector(..), selectorStr,
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
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
data BuildCfg =
BuildCfg {
_bcMedia :: Set MediaType,
_bcSelector :: [Selector]
}
deriving (Data, Eq, Ord, Read, Show, Typeable)
data CSS =
CSS {
_cssImports :: Map Text (Set MediaType),
_cssProps :: Map (Set MediaType) [Property]
}
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)
newtype MediaType = MediaType { _mediaTypeStr :: ByteString }
deriving (Data, Eq, Ord, Read, Show, Typeable)
instance IsString MediaType where
fromString = MediaType . Bu.fromString
data Property =
Property {
_propSelector :: [Selector],
_propName :: PropName,
_propValue :: PropValue,
_propImportant :: Bool
}
deriving (Data, Eq, Ord, Read, Show, Typeable)
newtype PropName = PropName { _propNameStr :: ByteString }
deriving (Data, Eq, Ord, Read, Show, Typeable)
instance IsString PropName where
fromString = PropName . Bu.fromString
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
newtype Selector = Selector { _selectorStr :: ByteString }
deriving (Data, Eq, Ord, Read, Show, Typeable)
instance IsString Selector where
fromString = Selector . Bu.fromString
type SetProp = forall m. SetPropM m
type SetPropM m = (MonadReader BuildCfg m, MonadWriter CSS m) => m ()
colorHex :: Word8 -> Builder
colorHex x =
fromChar (intToDigit (fromIntegral $ shiftR x 4)) <>
fromChar (intToDigit (fromIntegral $ x .&. 0x0F))
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