module Language.Css.Build (
Idents(..), ToExpr(..),
styleSheet, rules, ruleSets,
addImports, addRules, charset,
media, page, fontFace,
Sel', star, sels,
(/>), (/-), (/#), (/.), (/:),
Attrs(..), (!), (.=), (~=), (|=),
(<:>), important,
space, slash, comma,
spaces, slashes, commas,
fun, str, int, num,
deg, rad, grad, cword, rgb, hz, khz,
em, ex, px, in', cm, mm, pc, pt,
pct, ms, s, url,
aqua, black, blue, fuchsia, gray, green,
lime, maroon, navy, olive, orange, purple,
red, silver, teal, white, yellow
)
where
import Language.Css.Syntax
import Control.Applicative
class Idents a where
ident :: String -> a
instance Idents Ident where
ident = Ident
instance Idents String where
ident = id
class ToExpr a where
expr :: a -> Expr
instance ToExpr Expr where
expr = id
styleSheet :: Maybe AtCharSet -> [AtImport] -> [StyleBody] -> StyleSheet
styleSheet = StyleSheet
rules :: [StyleBody] -> StyleSheet
rules = styleSheet Nothing []
addImports :: [AtImport] -> StyleSheet -> StyleSheet
addImports is' (StyleSheet c is body) = StyleSheet c (is ++ is') body
addRules :: [StyleBody] -> StyleSheet -> StyleSheet
addRules rs (StyleSheet c is body) = StyleSheet c is $ rs ++ body
ruleSets :: [RuleSet] -> StyleSheet
ruleSets = StyleSheet Nothing [] . map SRuleSet
charset :: String -> StyleSheet -> StyleSheet
charset str (StyleSheet _ is body) = StyleSheet (Just $ AtCharSet str) is body
media :: [String] -> [RuleSet] -> StyleBody
media ms rs = SAtMedia $ AtMedia (map ident ms) rs
page :: Maybe String -> Maybe PseudoPage -> [Decl] -> StyleBody
page i p ds = SAtPage $ AtPage (ident <$> i) p ds
importStr :: String -> [Ident] -> AtImport
importStr str = AtImport (IStr str)
importUri :: String -> [Ident] -> AtImport
importUri str = AtImport (IUri $ Uri str)
fontFace :: [Decl] -> StyleBody
fontFace = SAtFontFace . AtFontFace
infixl 5 /-, />, /+
infixl 6 /#, /., !, /:
infixr 0 <:>
type Sel' = [Decl] -> RuleSet
star :: Sel'
star = RuleSet (return $ SSel $ UnivSel [])
instance Idents Sel' where
ident x = RuleSet (return $ SSel $ TypeSel x [])
sels :: [Sel'] -> Sel'
sels xs d = joinRules [] $ map ($ d) xs
where joinRules sels xs =
case xs of
[] -> RuleSet sels d
a:as -> joinRules (sels ++ getSels a) as
(/-) :: Sel' -> Sel' -> Sel'
(/-) = liftSel2 DescendSel
(/>) :: Sel' -> Sel' -> Sel'
(/>) = liftSel2 ChildSel
(/+) :: Sel' -> Sel' -> Sel'
(/+) = liftSel2 AdjSel
(/#) :: Sel' -> String -> Sel'
(/#) s id = liftSel1 (appendSubSel $ IdSel id) s
(/.) :: Sel' -> String -> Sel'
(/.) s cl = liftSel1 (appendSubSel $ ClassSel cl) s
(!) :: Sel' -> Attr -> Sel'
(!) s attr = liftSel1 (appendSubSel $ AttrSel attr) s
(/:) :: Sel' -> PseudoVal -> Sel'
(/:) s p = liftSel1 (appendSubSel $ PseudoSel p) s
liftSel1 :: (Sel -> Sel) -> (Sel' -> Sel')
liftSel1 f = liftA f'
where f' a = RuleSet (liftA f $ getSels a) $ getDecls a
liftSel2 :: (Sel -> Sel -> Sel) -> (Sel' -> Sel' -> Sel')
liftSel2 f = liftA2 f'
where f' a b = RuleSet (liftA2 f (getSels a) (getSels b)) $ getDecls a
instance Idents Attr where
ident = Attr
class Attrs a where
attr :: String -> a
instance Attrs Attr where
attr = Attr
instance Attrs AttrIdent where
attr = id
(.=) :: AttrIdent -> AttrVal -> Attr
(.=) = AttrIs
(~=) :: AttrIdent -> AttrVal -> Attr
(~=) = AttrIncl
(|=) :: AttrIdent -> AttrVal -> Attr
(|=) = AttrBegins
appendSubSel :: SubSel -> Sel -> Sel
appendSubSel s a =
case a of
SSel x -> case x of
UnivSel xs -> SSel $ UnivSel $ xs ++ [s]
TypeSel el xs -> SSel $ TypeSel el $ xs ++ [s]
DescendSel x y -> DescendSel (appendSubSel s x) (appendSubSel s y)
ChildSel x y -> ChildSel (appendSubSel s x) (appendSubSel s y)
AdjSel x y -> AdjSel (appendSubSel s x) (appendSubSel s y)
getSels :: RuleSet -> [Sel]
getSels (RuleSet xs _) = xs
getDecls :: RuleSet -> [Decl]
getDecls (RuleSet _ xs) = xs
instance Idents PseudoVal where
ident = PIdent . ident
(<:>) :: String -> Expr -> Decl
(<:>) a b = Decl Nothing (ident a) b
important :: Decl -> Decl
important (Decl _ a b) = Decl (Just Important) a b
space :: Expr -> Expr -> Expr
space = SpaceSep
spaces :: [Expr] -> Expr
spaces = foldl1 space
slash :: Expr -> Expr -> Expr
slash = SlashSep
slashes :: [Expr] -> Expr
slashes = foldl1 slash
comma :: Expr -> Expr -> Expr
comma = CommaSep
commas :: [Expr] -> Expr
commas = foldl1 comma
instance ToExpr a => ToExpr [a] where
expr x = case x of
[] -> ident ""
_ -> foldl1 space $ map expr x
instance Idents Expr where
ident = EVal . ident
instance Idents Value where
ident = VIdent . ident
instance ToExpr Value where
expr = EVal
fun :: ToExpr a => Ident -> a -> Func
fun str = Func str . expr
deg :: Double -> Expr
deg = expr . Deg
rad :: Double -> Expr
rad = expr . Rad
grad :: Double -> Expr
grad = expr . Grad
cword :: String -> Expr
cword = expr . Cword . checkWord
rgb :: Int -> Int -> Int -> Expr
rgb x0 x1 x2 = expr $ Crgb x0 x1 x2
hz :: Double -> Expr
hz = expr . Hz
khz :: Double -> Expr
khz = expr . KHz
em :: Double -> Expr
em = expr . Em
ex :: Double -> Expr
ex = expr . Ex
px :: Int -> Expr
px = expr . Px
in' :: Double -> Expr
in' = expr . In
cm :: Double -> Expr
cm = expr . Cm
mm :: Double -> Expr
mm = expr . Mm
pc :: Double -> Expr
pc = expr . Pc
pt :: Int -> Expr
pt = expr . Pt
pct :: Double -> Expr
pct = expr . Percentage
ms :: Double -> Expr
ms = expr . Ms
s :: Double -> Expr
s = expr . S
url :: String -> Expr
url = expr . Uri
checkWord x
| checkLeng x && checkNums x && checkFirst x = x
| otherwise = errorMsg
where errorMsg = error "must be number in hexadecimal notation"
checkLeng x
| length x == 4 || length x == 7 = True
| otherwise = error "string length must be 4 or 7"
checkNums x
| all (`elem` (['0' .. '9'] ++ ['a' .. 'f'] ++ ['A' .. 'F']))$ tail x = True
| otherwise = errorMsg
checkFirst x
| '#' == head x = True
| otherwise = error "first character must be #"
str :: String -> Expr
str = expr . VString
int :: Int -> Expr
int = expr
num :: Double -> Expr
num = expr
instance ToExpr Deg where
expr = expr . VDeg
instance ToExpr Rad where
expr = expr . VRad
instance ToExpr Grad where
expr = expr . VGrad
instance ToExpr Color where
expr = expr . VColor
instance ToExpr Hz where
expr = expr . VHz
instance ToExpr KHz where
expr = expr . VKHz
instance ToExpr Func where
expr = expr . VFunc
instance ToExpr Ident where
expr = expr . VIdent
instance ToExpr Int where
expr = expr . VInt
instance ToExpr Em where
expr = expr . VEm
instance ToExpr Ex where
expr = expr . VEx
instance ToExpr Px where
expr = expr . VPx
instance ToExpr In where
expr = expr . VIn
instance ToExpr Cm where
expr = expr . VCm
instance ToExpr Mm where
expr = expr . VMm
instance ToExpr Pc where
expr = expr . VPc
instance ToExpr Pt where
expr = expr . VPt
instance ToExpr Double where
expr = expr . VDouble
instance ToExpr Percentage where
expr = expr . VPercentage
instance ToExpr Ms where
expr = expr . VMs
instance ToExpr S where
expr = expr . VS
instance ToExpr Uri where
expr = expr . VUri
aqua = cword "#00ffff"
black = cword "#000000"
blue = cword "#0000ff"
fuchsia = cword "#ff00ff"
gray = cword "#808080"
green = cword "#008000"
lime = cword "#00ff00"
maroon = cword "#800000"
navy = cword "#000080"
olive = cword "#808000"
orange = cword "#ffA500"
purple = cword "#800080"
red = cword "#ff0000"
silver = cword "#c0c0c0"
teal = cword "#008080"
white = cword "#ffffff"
yellow = cword "#ffff00"