module Text.CSS.CleverCSS (cleverCSSConvert) where
import Control.Monad.Error
import Control.Monad.RWS
import Data.Char (toUpper, toLower)
import Data.List (findIndex)
import Text.Printf (printf)
import Text.ParserCombinators.Parsec hiding (newline)
import qualified Data.Map as Map
import Text.CSS.CleverCSSUtil
css_functions = ["url", "attr", "counter"]
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]
| Block !Line ![String] [Item]
deriving Eq
data Item = Property !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
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 (Block _ sels items) = (joinStr ", " sels) ++ ":\n" ++
unlines (map (" "++) (map show items))
instance Show Item where
show (Property _ name exprs) = name ++ ": " ++ joinShow " " exprs
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 (ExprList l) = joinShow ", " l
show (Subseq l) = joinShow " " l
show (String s) = cssShow s
show (Number n) = show (fromRational n)
show (Dim (n, u)) = show (fromRational 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)
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 (import_ <|> assign <|> cassign <|> block) ~>> end
where
import_ = do
atid <- at_ident
if atid == "import" then liftM2 Import getline exprseq_nl
else unexpected "at-identifier, expecting @import"
assign = liftM3 (Assign Always) getline varassign exprseq_nl
cassign = liftM3 (Assign IfNotAssigned) getline cvarassign exprseq_nl
block = do
line <- getline
selectornames <- selector False
firstitem <- subblock True <|> subgroup True <|> property True
restitems <- many $ (subblock False <|> subgroup False <|> property False)
updateState tail
return $! Block line selectornames (firstitem:restitems)
subblock fst = do
line <- getline
selectornames <- selector fst
firstitem <- subblock True <|> subgroup True <|> property True
restitems <- many $ (subblock False <|> subgroup False <|> property False)
updateState tail
return $! SubBlock line selectornames (firstitem:restitems)
subgroup fst = do
line <- getline
groupname <- grpname fst
firstitem <- property True
restitems <- many $ property False
updateState tail
return $! SubGroup line groupname (firstitem:restitems)
property fst = liftM3 Property getline (propname fst) exprseq_nl
selector fst = do
names <- selnames fst
return $! map trim (split "," names)
getline = liftM sourceLine getPosition
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"
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
where
expression = plusExpr `chainr1` listOp
listOp = op ',' >> return ExprListCons
plusOp = (op '+' >> return Plus) <|> (op '-' >> return Minus)
plusExpr = mulExpr `chainl1` plusOp
mulOp = (op '*' >> return Mul) <|> (op '/' >> return Divide) <|>
(op '%' >> return Modulo)
mulExpr = primary `chainl1` mulOp
primary = do
object <- parenthesized <|> str <|> dimension <|> number <|> color <|>
func <|> rgb <|> var <|> bare
calltails object
parenthesized = liftM Subseq $ between (op '(') (op ')') (many1 expression)
str = liftM String $ (sqstring <|> dqstring)
number = liftM (Number . readNum) num
dimension = liftM (Dim . readDim) dim
color = liftM (Color . Right . hexToColor) hexcolor
var = liftM Var varref
bare = do
name <- ident
if Map.member name colors then return $ Color (Left name)
else return $ Bare name
func = do
funcname <- choice (map funcall css_functions)
args <- expression
op ')'
return $! CSSFunc funcname args
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 (liftM 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 string
["em", "ex", "px", "cm", "mm", "in", "pt", "pc", "deg",
"rad", "grad", "ms", "s", "Hz", "kHz", "%"])
dqstring = (pws $ char '"' >> many1 (noneOf "\n\\\"" <|> escape) ~>> char '"')
<?> "string"
sqstring = (pws $ char '\'' >> many1 (noneOf "\n\\'" <|> escape) ~>> char '\'')
<?> "string"
hexcolor = (pws $ char '#' >> ((try $ count 6 hexDigit) <|> count 3 hexDigit))
<?> "color"
op c = (pws $ char c) <?> "operator " ++ [c]
data EvalError = EvalErr !Line !String
type EvalMonad = RWST (Map.Map String Expr) () [Topl] (Either EvalError) ()
instance Error EvalError where
strMsg s = EvalErr 0 s
instance Show EvalError where
show (EvalErr 0 msg) = ": " ++ msg
show (EvalErr l msg) = "(line " ++ show l ++ "):\n" ++ msg
translate :: [Topl] -> [(String, String)] -> Either EvalError [Topl]
translate toplevels initial_map =
fmap fst $ execRWST (resolve_toplevels toplevels) (eval_map Map.empty initial_map) []
where
eval_map :: Map.Map String Expr -> [(String, String)] -> Map.Map String Expr
eval_map map [] = map
eval_map map ((n,v):ds) = eval_map (Map.insert n
(evaluate map "initial variables" v) map) ds
resolve_toplevels :: [Topl] -> EvalMonad
resolve_toplevels (Block line sels items : ts) = do
resolve_block line sels items
resolve_toplevels ts
resolve_toplevels (Import line exprseq : ts) = do
exprs <- eval_exprseq exprseq
case exprs of
CSSFunc "url" u -> modify (Import line [CSSFunc "url" u] : )
v -> throwError $ EvalErr line $
"invalid thing to import, should be url(): " ++ show v
resolve_toplevels ts
resolve_toplevels (Assign how line name exprseq : ts) = do
ispresent <- asks (Map.member name)
if ispresent && how == IfNotAssigned then resolve_toplevels ts else do
exprs <- eval_exprseq exprseq
case exprs of
Error err -> throwError $ EvalErr line err
_ -> local (Map.insert name exprs) (resolve_toplevels ts)
resolve_toplevels [] = return ()
resolve_block line sels items = do
props <- mapM (resolve_item sels) items
modify (Block line sels (concat props) : )
resolve_item _ (Property line name exprseq) = do
exprs <- eval_exprseq exprseq
case exprs of
Error err -> throwError $ EvalErr line err
_ -> return [Property line name [exprs]]
resolve_item sels (SubBlock line subsels items) =
resolve_block line (combine_sels sels subsels) items >> return []
resolve_item _ (SubGroup _ name items) = mapM (resolve_group name) items
resolve_group name (Property line prop exprs) =
fmap head $ resolve_item [] (Property line (name ++ "-" ++ prop) exprs)
resolve_group _ _ = error "impossible item in group"
combine_sels 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)
eval_exprseq [] = return $ String ""
eval_exprseq [e] = asks id >>= return . (flip eval e)
eval_exprseq seq = do
varmap <- asks id
return $ findError (Bare . joinShow " ") $ map (eval varmap) seq
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 -> findError 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) -> evaluate 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 (show 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
evaluate varmap source string = case runParser exprseq [] "" string of
Left err -> Error $ showWithoutPos ("in "++source++":") err
Right [] -> String ""
Right [e] -> eval varmap e
Right seq -> findError Subseq $ map (eval varmap) seq
findError cons xs = head $ [Error e | Error e <- xs] ++ [cons xs]
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
format :: [Topl] -> String
format blocks = concatMap format_block blocks where
format_block (Block _ sels props) =
joinStr ", " sels ++ " {\n" ++ unlines (map format_prop props) ++ "}\n\n"
format_block (Import _ exprs) = "@import " ++ joinShow " " exprs ++ ";\n"
format_block (Assign _ _ _ _) = error "remaining assignment in eval result"
format_prop (Property _ name [val]) = " " ++ name ++ ": " ++ show val ++ ";"
format_prop (Property _ _ _) = error "property has not exactly one value"
format_prop _ = error "remaining subitems in block"
cleverCSSConvert :: SourceName -> String -> [(String, String)] -> Either String String
cleverCSSConvert name input initial_map =
case runParser parser [0] name (preprocess input) of
Left err -> Left $ "Parse error " ++ show err
Right parse -> case translate parse initial_map of
Left evalerr -> Left $ "Evaluation error " ++ show evalerr
Right blocks -> Right $ format (reverse blocks)