module Text.CSS.CleverCSS (cleverCSSConvert) where
import Control.Applicative (Applicative(..), (<$>))
import Control.Monad.Error
import Control.Monad.RWS
import Data.Char (toUpper, toLower)
import Data.List (findIndex)
import Data.Sequence (Seq, singleton)
import Text.Printf (printf)
import Text.ParserCombinators.Parsec hiding (newline)
import qualified Control.Exception as E
import qualified Data.Foldable as F
import qualified Data.Map as Map
import Text.CSS.CleverCSSUtil
css_functions = ["url", "attr", "counter"]
#if PARSEC2
instance Applicative (GenParser toc st) where
pure = return
(<*>) = ap
#endif
type CSSNumber = (Rational, String)
type CSSColor = Either String Color
data AssignType = Always | IfNotAssigned deriving Eq
data Topl = Assign !AssignType !Line !String [Expr]
| Import !Line [Expr]
| Include !Line [Expr]
| Macro !Line !String ![String] [Item]
| Block !Line ![String] [Item]
| SetFilename !String
deriving Eq
data Item = Property !Line !String [Expr]
| UseMacro !Line !String [Expr]
| SubBlock !Line ![String] [Item]
| SubGroup !Line !String [Item]
deriving Eq
data Expr = Plus Expr Expr
| Minus Expr Expr
| Mul Expr Expr
| Divide Expr Expr
| Modulo Expr Expr
| ExprListCons Expr Expr
| ExprList [Expr]
| Subseq [Expr]
| Call Expr !String (Maybe Expr)
| Var !String
| Bare !String
| String !String
| CSSFunc !String Expr
| Number !Rational
| Dim !CSSNumber
| Color !CSSColor
| Rgb Expr Expr Expr
| Error !String
| NoExpr
deriving Eq
instance Show Topl where
show (Assign Always _ name exprs) = name ++ " = " ++ joinShow " " exprs
show (Assign IfNotAssigned _ name exprs) = name ++ " ?= " ++ joinShow " " exprs
show (Import _ exprs) = "@import " ++ joinShow " " exprs
show (Include _ exprs) = "@include " ++ joinShow " " exprs
show (Macro _ sel argnames items) = "@define " ++ sel ++ "(" ++ joinStr ", " argnames ++
"):\n" ++ unlines (map (" "++) (map show items))
show (Block _ sels items) = (joinStr ", " sels) ++ ":\n" ++
unlines (map (" "++) (map show items))
show (SetFilename s) = "<SetFilename " ++ s ++ ">"
instance Show Item where
show (Property _ name exprs) = name ++ ": " ++ joinShow " " exprs
show (UseMacro _ name args) = "%" ++ name ++ "(" ++ joinShow ", " args ++ ")"
show (SubGroup _ name items) = name ++ "->\n" ++
unlines (map (" "++) (map show items))
show (SubBlock _ sels items) = (joinStr ", " sels) ++ ":\n" ++
unlines (map (" "++) (map show items))
instance Show Expr where
show (Plus a b) = printf "<Plus %s %s>" (show a) (show b)
show (Minus a b) = printf "<Minus %s %s>" (show a) (show b)
show (Mul a b) = printf "<Mul %s %s>" (show a) (show b)
show (Divide a b) = printf "<Divide %s %s>" (show a) (show b)
show (Modulo a b) = printf "<Modulo %s %s>" (show a) (show b)
show (ExprListCons a b) = printf "<ExprListCons %s %s>" (show a) (show b)
show (Call e n Nothing) = printf "<Call %s.%s()>" (show e) n
show (Call e n (Just a)) = printf "<Call %s.%s(%s)>" (show e) n (show a)
show (Var a) = printf "<Var %s>" a
show (Rgb r g b) = printf "<Rgb %s %s %s>" (show r) (show g) (show b)
show (Error e) = printf "<Error: %s>" e
show NoExpr = "<NoExpr>"
show (ExprList l) = joinShow ", " l
show (Subseq l) = joinShow " " l
show (String s) = cssShow s
show (Number n) = showRat n
show (Dim (n, u)) = showRat n ++ u
show (CSSFunc name args) = name ++ "(" ++ show args ++ ")"
show (Color (Left n)) = n
show (Color (Right (r,g,b))) = case Map.lookup (r,g,b) reverse_colors of
Just name -> name
Nothing -> printf "#%02x%02x%02x" r g b
show (Bare s) = s
nl = char '\n' <?> "end of line"
ws = many (char ' ' <?> "whitespace")
comment = string "//" >> many (noneOf "\n") <?> "comment"
wscomment = ws >> option "" (try comment)
emptyLine = wscomment >> nl <?> "empty line"
newline = emptyLine >> many (try emptyLine) <?> "newline"
pws parser = parser ~>> wscomment
ident = (pws $ try $ (perhaps $ char '-') +++
((char '_' <|> letter <|> escape) +:+
many (char '_' <|> char '-' <|> alphaNum <|> escape)))
<?> "identifier"
escape = char '\\' >> (uniescape <|> charescape) where
uniescape = (varCount 1 6 hexDigit ~>> perhaps (oneOf " \n"))
>>= (return . hexToString)
charescape = noneOf ("\n" ++ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F'])
at_ident = (char '@' >> ident) <?> "at-identifier"
varname = (char '_' <|> letter) +:+ many (char '_' <|> alphaNum)
parser :: GenParser Char [Int] [Topl]
parser = many emptyLine >> many (atclause <|> assign <|> cassign <|> block) ~>> end
where
atclause = do
atid <- at_ident
case atid of
"import" -> Import <$> getline <*> exprseq_nl
"include" -> Include <$> getline <*> exprseq_nl
"define" -> Macro <$> getline <*> defname <*> defargs <*> blockitems
_ -> unexpected "at-identifier, expecting @import, @include or @define"
assign = Assign Always <$> getline <*> varassign <*> exprseq_nl
cassign = Assign IfNotAssigned <$> getline <*> cvarassign <*> exprseq_nl
blockitems = do
firstitem <- subblock True <|> subgroup True <|> defsubst True <|> property True
restitems <- many $ (subblock False <|> subgroup False <|>
defsubst False <|> property False)
updateState tail
return (firstitem:restitems)
block = Block <$> getline <*> selector False <*> blockitems
subblock fst = SubBlock <$> getline <*> selector fst <*> blockitems
subgroup fst = do
line <- getline
groupname <- grpname fst
firstitem <- property True
restitems <- many $ property False
updateState tail
return $! SubGroup line groupname (firstitem:restitems)
defsubst fst = UseMacro <$> getline <*> macname fst <*> (exprs2list <$> macargs)
property fst = Property <$> getline <*> propname fst <*> exprseq_nl
selector fst = do
names <- selnames fst
return $! map trim (split "," names)
getline = sourceLine <$> getPosition
exprs2list (ExprListCons a b) = a : exprs2list b
exprs2list c = [c]
varassign = (try $ varname ~>> (ws >> char '=' >> ws)) <?> "assignment"
cvarassign = (try $ varname ~>> (ws >> string "?=" >> ws)) <?> "assignment"
selnames fst = (try $ indented fst $
noneOf "\n" `manyTill` (try $ char ':' >> newline))
<?> "selectors"
defname = varname <?> "macro name"
defargs = (char '(' >> (varname `sepBy` (char ',' >> ws)) ~>>
(pws $ char ')') ~>> char ':' ~>> newline)
<?> "macro arguments"
macname fst = (try $ indented fst $ char '%' >> varname) <?> "macro substitution"
macargs = (char '(' >> option NoExpr expression ~>> char ')' ~>> newline)
<?> "macro arguments"
propname fst = (try $ indented fst $ ident ~>> char ':') <?> "property name"
grpname fst = (try $ indented fst $ grpident ~>> (string "->" >> newline))
<?> "group name"
grpident = (pws $ try $ many1 letter +++
manyConcat (try $ char '-' +:+ many1 letter))
manyConcat = liftM concat . many
end = ((try $ string "__END__" >> nl) >> return ()) <|> eof
indented fst parser = do
ind <- ws
tok <- parser
state <- getState
let ilen = length ind
olen = head state
if fst then if ilen > olen then do
setState (length ind : state)
return tok
else unexpected "indentation"
else if ilen == olen then return tok else unexpected "indentation level"
exprseq_nl = exprseq ~>> (option ';' (char ';') >> newline)
exprseq :: GenParser Char [Int] [Expr]
exprseq = ws >> many1 expression
expression :: GenParser Char [Int] Expr
expression = plusExpr `chainr1` listOp
where
listOp = op ',' >> return ExprListCons
plusExpr = mulExpr `chainl1` plusOp
plusOp = (op '+' >> return Plus) <|> (op '-' >> return Minus)
mulExpr = primary `chainl1` mulOp
mulOp = (op '*' >> return Mul) <|> (op '/' >> return Divide) <|>
(op '%' >> return Modulo)
primary = do
object <- parenthesized <|> str <|> dimension <|> number <|> color <|>
func <|> rgb <|> var <|> bare
calltails object
parenthesized = Subseq <$> between (op '(') (op ')') (many1 expression)
str = String <$> (sqstring <|> dqstring)
number = (Number . readNum) <$> num
dimension = (Dim . readDim) <$> dim
color = (Color . Right . hexToColor) <$> hexcolor
var = Var <$> varref
bare = do
name <- ident
if Map.member name colors then return $ Color (Left name)
else return $ Bare name
func = CSSFunc <$> choice (map funcall css_functions) <*> expression ~>> op ')'
rgb = do
funcall "rgb"
channels <- expression
op ')'
case channels of (ExprListCons _ (ExprListCons _ (ExprListCons _ _))) ->
fail "too many arguments for rgb()"
(ExprListCons a (ExprListCons b c)) ->
return $! Rgb a b c
_ -> fail "not enough expressions for rgb()"
calltails object = do
calltail <- option Nothing (call object)
case calltail of
Nothing -> return object
Just called -> calltails called
call object = do
methname <- methcall
callexpr <- option Nothing (Just <$> expression)
op ')'
return $! Just (Call object methname callexpr)
varref = (pws $ char '$' >> varname) <?> "variable reference"
funcall fn = (pws $ try $ string fn ~>> char '(') <?> "function " ++ fn
methcall = (pws $ char '.' >> varname ~>> (ws >> char '(')) <?> "method call"
num = (pws $ (perhaps $ char '-') +++ many1 digit +++
option "" (char '.' +:+ many1 digit)) <?> "number"
dim = (pws $ try $ num +++ ws +++ unit) <?> "dimension"
unit = choice (map (try . string)
["em", "ex", "px", "cm", "mm", "in", "pt", "pc", "deg",
"rad", "grad", "ms", "s", "Hz", "kHz", "%"])
dqstring = (pws $ char '"' >> many (noneOf "\n\\\"" <|> escape) ~>> char '"')
<?> "string"
sqstring = (pws $ char '\'' >> many (noneOf "\n\\'" <|> escape) ~>> char '\'')
<?> "string"
hexcolor = (pws $ char '#' >> ((try $ count 6 hexDigit) <|> count 3 hexDigit))
<?> "color"
op c = (pws $ char c) <?> "operator " ++ show c
data EvalError = EvalErr !SourceName !Line !String
type Dict cont = Map.Map String cont
data Env = Env { vars :: Dict Expr, macros :: Dict (Line, [String], [Item]) }
type Eval res = RWST Env (Seq Topl) SourceName (ErrorT EvalError IO) res
instance Error EvalError where
strMsg s = EvalErr "" 0 s
instance Show EvalError where
show (EvalErr f 0 msg) = "(file " ++ show f ++ "): " ++ msg
show (EvalErr f l msg) = "(file " ++ show f ++ ", line " ++ show l ++ "):\n" ++ msg
evalErr line err = do
fname <- get
throwError $ EvalErr fname line err
updateVars f r = r { vars = f (vars r) }
updateMacros f r = r { macros = f (macros r) }
translate :: String -> [Topl] -> Dict Expr -> IO (Either EvalError (Seq Topl))
translate filename toplevels varmap = do
let initialEnv = Env { vars = varmap, macros = Map.empty }
res <- runErrorT $ execRWST (resolveToplevels toplevels) initialEnv filename
return (snd <$> res)
where
emitBlock = tell . singleton
resolveToplevels :: [Topl] -> Eval ()
resolveToplevels (SetFilename filename : ts) = do
put filename
resolveToplevels ts
resolveToplevels (Block line sels items : ts) = do
resolveBlock line sels items
resolveToplevels ts
resolveToplevels (Macro line sel argnames items : ts) = do
local (updateMacros $ Map.insert sel (line, argnames, items)) (resolveToplevels ts)
resolveToplevels (Import line exprseq : ts) = do
exprs <- evalExprseq line exprjoin exprseq
case exprs of
CSSFunc "url" u -> emitBlock $ Import line [CSSFunc "url" u]
v -> evalErr line $ "invalid thing to import, should be url(): " ++ show v
resolveToplevels ts
resolveToplevels (Include line exprseq : ts) = do
exprs <- evalExprseq line exprjoin exprseq
case exprs of
String filename -> do
oldfilename <- get
contents <- liftIO $ E.try (readFile filename)
case contents of
Left ex -> evalErr line ("error reading included file: " ++
show (ex :: IOError))
Right c ->
case runParser parser [0] filename (preprocess c) of
Left err -> evalErr line $ "parse error in @include " ++ show err
Right parse -> resolveToplevels ((SetFilename filename : parse) ++
(SetFilename oldfilename : ts))
v -> evalErr line $ "invalid thing to include, should be a string: " ++ show v
resolveToplevels (Assign how line name exprseq : ts) = do
ispresent <- asks (Map.member name . vars)
if ispresent && how == IfNotAssigned then resolveToplevels ts else do
exprs <- evalExprseq line exprjoin exprseq
local (updateVars $ Map.insert name exprs) (resolveToplevels ts)
resolveToplevels [] = return ()
resolveBlock :: Line -> [String] -> [Item] -> Eval ()
resolveBlock line sels items = do
props <- mapM (resolveItem sels) items
emitBlock $ Block line sels (concat props)
resolveItem :: [String] -> Item -> Eval [Item]
resolveItem _ (Property line name exprseq) = do
expr <- evalExprseq line exprjoin exprseq
return [Property line name [expr]]
resolveItem sels (UseMacro line name args) = do
lookresult <- asks (Map.lookup name . macros)
case lookresult of
Nothing -> evalErr line ("macro " ++ name ++ " is not defined")
Just (_, argnames, items) -> do
let numargs = length argnames
given = length args
if numargs /= given
then evalErr line ("wrong number of arguments for macro " ++ name ++
": given " ++ show given ++ ", should be " ++ show numargs)
else do
evaledargs <- evalExprseq line id args
let updfunc = updateVars $ Map.union (Map.fromList $ zip argnames evaledargs)
local updfunc (concat <$> mapM (resolveItem sels) items)
resolveItem sels (SubBlock line subsels items) =
resolveBlock line (combineSels sels subsels) items >> return []
resolveItem _ (SubGroup _ name items) = mapM (resolveGroup name) items
resolveGroup name (Property line prop exprs) =
head <$> resolveItem [] (Property line (name ++ "-" ++ prop) exprs)
resolveGroup _ _ = error "impossible item in group"
combineSels sels subsels = [comb s1 s2 | s1 <- sels, s2 <- subsels]
where comb s1 s2 = maybe (s1 ++ " " ++ s2)
(\i -> (take i s2) ++ s1 ++ (drop (i+1) s2))
(findIndex (=='&') s2)
exprjoin [e] = e
exprjoin es = Bare $ joinShow " " es
evalExprseq _ cons [] = return $ cons [String ""]
evalExprseq line cons seq = do
varmap <- asks vars
case findError (map (eval varmap) seq) of
[Error err] -> evalErr line err
result -> return $ cons result
eval varmap exp = let eval' = eval varmap in case exp of
Var a -> case Map.lookup a varmap of
Just val -> val
Nothing -> Error $ "variable " ++ a ++ " is not defined"
Plus a b -> case (eval' a, eval' b) of
(String s, String t) -> String (s ++ t)
(Number n, Number m) -> Number (n + m)
(Dim n, Dim m) | Just (n1, m1, w) <- unitconv n m -> Dim (n1 + m1, w)
(Dim (n, u), Number m) -> Dim (n + m, u)
(Number m, Dim (n, u)) -> Dim (m + n, u)
(Color col, Number n) -> Color $ Right $ modifyChannels (+) (rgbColor col) n
(CSSFunc "url" (String url), String s) -> CSSFunc "url" (String $ url ++ s)
(e@(Error _), _) -> e
(_, e@(Error _)) -> e
(x, y) -> Error ("cannot add " ++ show x ++ " and " ++ show y)
Minus a b -> case (eval' a, eval' b) of
(Number n, Number m) -> Number (n m)
(Dim n, Dim m) | Just (n1, m1, w) <- unitconv n m -> Dim (n1 m1, w)
(Dim (n, u), Number m) -> Dim (n m, u)
(Number m, Dim (n, u)) -> Dim (m n, u)
(Color col, Number n) -> Color $ Right $ modifyChannels () (rgbColor col) n
(e@(Error _), _) -> e
(_, e@(Error _)) -> e
(x, y) -> Error ("cannot subtract " ++ show x ++ " and " ++ show y)
Mul a b -> case (eval' a, eval' b) of
(String s, Number n) -> String $ concat (replicate (floor n) s)
(Number n, String s) -> String $ concat (replicate (floor n) s)
(Number n, Number m) -> Number (n * m)
(Dim (n, u), Number m) -> Dim (n * m, u)
(Number m, Dim (n, u)) -> Dim (m * n, u)
(e@(Error _), _) -> e
(_, e@(Error _)) -> e
(x, y) -> Error ("cannot multiply " ++ show x ++ " and " ++ show y)
Divide a b -> case (eval' a, eval' b) of
(Number n, Number m) -> case m of
0 -> Error "divide by zero"
m -> Number (n / m)
(Dim (n, u), Number m) -> case m of
0 -> Error "divide by zero"
m -> Dim (n / m, u)
(e@(Error _), _) -> e
(_, e@(Error _)) -> e
(x, y) -> Error ("cannot divide " ++ show x ++ " by " ++ show y)
Modulo a b -> case (eval' a, eval' b) of
(Number n, Number m) -> case m of
0 -> Error "modulo by zero"
m -> Number (n `ratMod` m)
(Dim (n, u), Number m) -> case m of
0 -> Error "modulo by zero"
m -> Dim (n `ratMod` m, u)
(e@(Error _), _) -> e
(_, e@(Error _)) -> e
(x, y) -> Error ("cannot calculate modulus of " ++ show x ++ " and " ++ show y)
ExprListCons a b -> case (eval' a, eval' b) of
(_, e@(Error _)) -> e
(e@(Error _), _) -> e
(e, ExprList es) -> ExprList (e:es)
(e1, e2) -> ExprList [e1, e2]
Subseq es -> findError2 Subseq (map eval' es)
CSSFunc name args -> case (name, eval' args) of
("url", String url) -> CSSFunc "url" (String url)
("attr", args) -> CSSFunc "attr" args
("counter", args) -> CSSFunc "counter" args
(name, args) -> Error $ printf "invalid CSS function: %s(%s)" name (show args)
Call exp name arg -> case (name, eval' exp, fmap eval' arg) of
(_, e@(Error _), _) -> e
(_, _, Just e@(Error _)) -> e
("bare", String s, Nothing) -> Bare s
("string", String s, Nothing) -> String s
("string", v, Nothing) -> String (show v)
("length", String s, Nothing) -> Number $ toRational (length s)
("upper", String s, Nothing) -> String (map toUpper s)
("lower", String s, Nothing) -> String (map toLower s)
("strip", String s, Nothing) -> String (trim s)
("split", String s, Just (String delim)) ->
ExprList (map String (split delim s))
("eval", String s, Nothing) -> evalString varmap "evaled string" s
("round", Number n, Just (Number p)) -> Number (roundRat n p)
("round", Number n, Nothing) -> Number (roundRat n 0)
("round", Dim (n, u), Just (Number p)) -> Dim (roundRat n p, u)
("round", Dim (n, u), Nothing) -> Dim (roundRat n 0, u)
("abs", Number n, Nothing) -> Number (abs n)
("abs", Dim (n, u), Nothing) -> Dim (abs n, u)
("length", ExprList l, Nothing) -> Number $ toRational (length l)
("length", Subseq l, Nothing) -> Number $ toRational (length l)
("join", ExprList l, Nothing) -> String $ joinShow ", " l
("join", Subseq l, Nothing) -> String $ joinShow " " l
("join", ExprList l, Just (String delim)) -> String $ joinShow delim l
("join", Subseq l, Just (String delim)) -> String $ joinShow delim l
("list", l@(ExprList _), Nothing) -> l
("list", Subseq l, Nothing) -> ExprList l
("seq", l@(Subseq _), Nothing) -> l
("seq", ExprList l, Nothing) -> Subseq l
("brighten", Color col, arg) ->
Color $ Right $ brightenColor (rgbColor col) (getAmount arg)
("darken", Color col, arg) ->
Color $ Right $ darkenColor (rgbColor col) (getAmount arg)
(name, exp, arg) ->
Error $ printf "cannot call method %s(%s) on %s" name (jshow arg) (show exp)
Rgb r g b -> case (eval' r, eval' g, eval' b) of
(Number r', Number g', Number b') -> Color $ Right (cx r', cx g', cx b')
(Dim (r', "%"), Dim (g', "%"), Dim (b', "%")) ->
Color $ Right (cx (r' * 2.55), cx (g' * 2.55), cx (b' * 2.55))
_ -> Error "rgb() arguments must be numbers or percentages"
where cx = inrange 0 255 . floor
atom -> atom
where
jshow Nothing = ""
jshow (Just a) = show a
rgbColor = either (colors Map.!) id
getAmount arg = case arg of
Nothing -> 0.1
Just (Number am) -> (fromRational am) / 100
Just (Dim (am, "%")) -> (fromRational am) / 100
_ -> 0
findError xs = head $ [[Error e] | Error e <- xs] ++ [xs]
findError2 cons xs = head $ [Error e | Error e <- xs] ++ [cons xs]
evalString :: Dict Expr -> SourceName -> String -> Expr
evalString varmap source string = case runParser exprseq [] "" string of
Left err -> Error $ showWithoutPos ("in " ++ source ++ ":") err
Right [] -> String ""
Right [e] -> eval varmap e
Right seq -> findError2 Subseq $ map (eval varmap) seq
evalMap :: Dict Expr -> [(String, String)] -> Dict Expr
evalMap map [] = map
evalMap map ((n,v):ds) = evalMap (Map.insert n
(evalString map "initial variables" v) map) ds
format :: Seq Topl -> String
format blocks = F.foldl (\x y -> x ++ formatBlock y) "" blocks where
formatBlock (Block _ sels props) =
joinStr ", " sels ++ " {\n" ++ unlines (map formatProp props) ++ "}\n\n"
formatBlock (Import _ exprs) = "@import " ++ joinShow " " exprs ++ ";\n"
formatBlock (Include _ _) = error "remaining include in eval result"
formatBlock (Macro _ _ _ _) = error "remaining definition in eval result"
formatBlock (Assign _ _ _ _) = error "remaining assignment in eval result"
formatBlock (SetFilename _) = error "remaining filename in eval result"
formatProp (Property _ name [val]) = " " ++ name ++ ": " ++ show val ++ ";"
formatProp (Property _ _ _) = error "property has not exactly one value"
formatProp _ = error "remaining subitems in block"
cleverCSSConvert :: SourceName
-> String
-> [(String, String)]
-> IO (Either String String)
cleverCSSConvert name input initial_map =
case runParser parser [0] name (preprocess input) of
Left err -> return . Left $ "Parse error " ++ show err
Right parse -> do
result <- translate name parse (evalMap Map.empty initial_map)
case result of
Left evalerr -> return . Left $ "Evaluation error " ++ show evalerr
Right blocks -> return . Right $ format blocks