1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
{-# LANGUAGE OverloadedStrings #-}
-- | Parse CSS with parseNestedBlocks and render it with renderNestedBlock
module Text.CSS.Parse
( NestedBlock(..)
, parseNestedBlocks
, parseBlocks
, parseBlock
, attrParser
, attrsParser
, blockParser
, blocksParser
, parseAttr
, parseAttrs
) where
import Prelude hiding (takeWhile, take)
import Data.Attoparsec.Text
import Data.Text (Text, strip)
import Control.Applicative ((<|>), many, (<$>))
import Data.Char (isSpace)
type CssBlock = (Text, [(Text, Text)])
data NestedBlock = NestedBlock Text [NestedBlock] -- ^ for example a media query
| LeafBlock CssBlock
deriving (Eq, Show)
-- | The preferred parser, will capture media queries
parseNestedBlocks :: Text -> Either String [NestedBlock]
parseNestedBlocks = parseOnly nestedBlocksParser
-- | The original parser of basic CSS, but throws out media queries
parseBlocks :: Text -> Either String [CssBlock]
parseBlocks = parseOnly blocksParser
parseBlock :: Text -> Either String CssBlock
parseBlock = parseOnly blockParser
parseAttrs :: Text -> Either String [(Text, Text)]
parseAttrs = parseOnly attrsParser
parseAttr :: Text -> Either String (Text, Text)
parseAttr = parseOnly attrParser
skipWS :: Parser ()
skipWS = (string "/*" >> endComment >> skipWS)
<|> (skip isSpace >> skipWhile isSpace >> skipWS)
<|> return ()
where
endComment = do
skipWhile (/= '*')
(do
_ <- char '*'
(char '/' >> return ()) <|> endComment
) <|> fail "Missing end comment"
attrParser :: Parser (Text, Text)
attrParser = do
skipWS
key <- takeWhile1 (\c -> c /= ':' && c /= '{' && c /= '}')
_ <- char ':' <|> fail "Missing colon in attribute"
value <- valueParser
return (strip key, strip value)
valueParser :: Parser Text
valueParser = takeWhile (\c -> c /= ';' && c /= '}')
attrsParser :: Parser [(Text, Text)]
attrsParser = (do
a <- attrParser
(char ';' >> skipWS >> ((a :) <$> attrsParser))
<|> return [a]
) <|> return []
blockParser :: Parser (Text, [(Text, Text)])
blockParser = do
skipWS
sel <- takeWhile (/= '{')
_ <- char '{'
attrs <- attrsParser
skipWS
_ <- char '}'
return (strip sel, attrs)
nestedBlockParser :: Parser NestedBlock
nestedBlockParser = do
skipWS
sel <- strip <$> takeTill (== '{')
_ <- char '{'
skipWS
unknown <- strip <$> takeTill (\c -> c == '{' || c == '}' || c == ':')
mc <- peekChar
res <- case mc of
Nothing -> fail "unexpected end of input"
Just c -> nestedParse sel unknown c
skipWS
_ <- char '}'
return res
where
-- no colon means no content
nestedParse sel _ '}' = return $ LeafBlock (sel, [])
nestedParse sel unknown ':' = do
_ <- char ':'
value <- valueParser
(char ';' >> return ()) <|> return ()
skipWS
moreAttrs <- attrsParser
return $ LeafBlock (sel, (unknown, strip value) : moreAttrs)
-- TODO: handle infinite nesting
nestedParse sel unknown '{' = do
_ <- char '{'
attrs <- attrsParser
skipWS
_ <- char '}'
blocks <- blocksParser
return $ NestedBlock sel $ map LeafBlock $ (unknown, attrs) : blocks
nestedParse _ _ c = fail $ "expected { or : but got " ++ [c]
blocksParser :: Parser [(Text, [(Text, Text)])]
blocksParser = many blockParser
nestedBlocksParser :: Parser [NestedBlock]
nestedBlocksParser = many nestedBlockParser
|
