git.iko.soy/typeable/html-parse
on master help sign in
Add comments
f4e0d0eBen Gamari
Text/HTML/Parser.hs+27−23
compare with master
unifiedsplit
@@ -1,6 +1,10 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3
3
4+-- | This is a performance-oriented HTML tokenizer aim at web-crawling
5+-- applications. It follows the HTML5 parsing specification quite closely,
6+-- so it behaves reasonable well on ill-formed documents from the open Web.
7+--
4module Text.HTML.Parser
8module Text.HTML.Parser
5 ( TagName, AttrName, AttrValue
9 ( TagName, AttrName, AttrValue
6 , Token(..)
10 , Token(..)
@@ -51,11 +55,11 @@ instance NFData Token where
51 rnf (Comment b) = rnf $ B.toLazyText b
55 rnf (Comment b) = rnf $ B.toLazyText b
52 rnf _ = ()
56 rnf _ = ()
53
57
54−-- | Start in the data state.
58+-- | Parse a single 'Token'.
55token :: Parser Token
59token :: Parser Token
56−token = dataState
60+token = dataState -- Start in the data state.
57
61
58−-- | 8.2.4.1: Data state
62+-- | /§8.2.4.1/: Data state
59dataState :: Parser Token
63dataState :: Parser Token
60dataState = do
64dataState = do
61 content <- takeWhile (/= '<')
65 content <- takeWhile (/= '<')
@@ -63,7 +67,7 @@ dataState = do
63 then return $ ContentText content
67 then return $ ContentText content
64 else char '<' >> tagOpen
68 else char '<' >> tagOpen
65
69
66−-- | 8.2.4.3: Tag open state
70+-- | /§8.2.4.3/: Tag open state
67tagOpen :: Parser Token
71tagOpen :: Parser Token
68tagOpen =
72tagOpen =
69 (char '!' >> markupDeclOpen)
73 (char '!' >> markupDeclOpen)
@@ -80,7 +84,7 @@ tagOpen =
80 other = do
84 other = do
81 return $ ContentChar '<'
85 return $ ContentChar '<'
82
86
83−-- | 8.2.4.9: End tag open state
87+-- | /§8.2.4.9/: End tag open state
84-- TODO: This isn't right
88-- TODO: This isn't right
85endTagOpen :: Parser Token
89endTagOpen :: Parser Token
86endTagOpen = do
90endTagOpen = do
@@ -88,7 +92,7 @@ endTagOpen = do
88 char '>'
92 char '>'
89 return $ TagClose name
93 return $ TagClose name
90
94
91−-- | 8.2.4.10: Tag name state
95+-- | /§8.2.4.10/: Tag name state
92--
96--
93-- deviation: no lower-casing
97-- deviation: no lower-casing
94tagName :: Parser Token
98tagName :: Parser Token
@@ -98,13 +102,13 @@ tagName = do
98 <|> (char '/' >> selfClosingStartTag tag [])
102 <|> (char '/' >> selfClosingStartTag tag [])
99 <|> (char '>' >> return (TagOpen tag []))
103 <|> (char '>' >> return (TagOpen tag []))
100
104
101−-- | 8.2.4.43: Self-closing start tag state
105+-- | /§8.2.4.43/: Self-closing start tag state
102selfClosingStartTag :: TagName -> [Attr] -> Parser Token
106selfClosingStartTag :: TagName -> [Attr] -> Parser Token
103selfClosingStartTag tag attrs = do
107selfClosingStartTag tag attrs = do
104 (char '>' >> return (TagOpen tag attrs))
108 (char '>' >> return (TagOpen tag attrs))
105 <|> beforeAttrName tag attrs
109 <|> beforeAttrName tag attrs
106
110
107−-- | 8.2.4.34: Before attribute name state
111+-- | /§8.2.4.34/: Before attribute name state
108--
112--
109-- deviation: no lower-casing
113-- deviation: no lower-casing
110beforeAttrName :: TagName -> [Attr] -> Parser Token
114beforeAttrName :: TagName -> [Attr] -> Parser Token
@@ -115,7 +119,7 @@ beforeAttrName tag attrs = do
115 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
119 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
116 <|> attrName tag attrs
120 <|> attrName tag attrs
117
121
118−-- | 8.2.4.35: Attribute name state
122+-- | /§8.2.4.35/: Attribute name state
119attrName :: TagName -> [Attr] -> Parser Token
123attrName :: TagName -> [Attr] -> Parser Token
120attrName tag attrs = do
124attrName tag attrs = do
121 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
125 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
@@ -125,7 +129,7 @@ attrName tag attrs = do
125 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
129 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
126 -- <|> -- TODO: NULL
130 -- <|> -- TODO: NULL
127
131
128−-- | 8.2.4.36: After attribute name state
132+-- | /§8.2.4.36/: After attribute name state
129afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
133afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
130afterAttrName tag attrs name = do
134afterAttrName tag attrs name = do
131 skipWhile $ inClass "\x09\x0a\x0c "
135 skipWhile $ inClass "\x09\x0a\x0c "
@@ -134,7 +138,7 @@ afterAttrName tag attrs name = do
134 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
138 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
135 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
139 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
136
140
137−-- | 8.2.4.37: Before attribute value state
141+-- | /§8.2.4.37/: Before attribute value state
138beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
142beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
139beforeAttrValue tag attrs name = do
143beforeAttrValue tag attrs name = do
140 skipWhile $ inClass "\x09\x0a\x0c "
144 skipWhile $ inClass "\x09\x0a\x0c "
@@ -143,28 +147,28 @@ beforeAttrValue tag attrs name = do
143 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
147 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
144 <|> attrValueUnquoted tag attrs name
148 <|> attrValueUnquoted tag attrs name
145
149
146−-- | 8.2.4.38: Attribute value (double-quoted) state
150+-- | /§8.2.4.38/: Attribute value (double-quoted) state
147attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
151attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
148attrValueDQuoted tag attrs name = do
152attrValueDQuoted tag attrs name = do
149 value <- takeWhile (/= '"')
153 value <- takeWhile (/= '"')
150 char '"'
154 char '"'
151 afterAttrValueQuoted tag attrs name value
155 afterAttrValueQuoted tag attrs name value
152
156
153−-- | 8.2.4.39: Attribute value (single-quoted) state
157+-- | /§8.2.4.39/: Attribute value (single-quoted) state
154attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
158attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
155attrValueSQuoted tag attrs name = do
159attrValueSQuoted tag attrs name = do
156 value <- takeWhile (/= '\'')
160 value <- takeWhile (/= '\'')
157 char '\''
161 char '\''
158 afterAttrValueQuoted tag attrs name value
162 afterAttrValueQuoted tag attrs name value
159
163
160−-- | 8.2.4.40: Attribute value (unquoted) state
164+-- | /§8.2.4.40/: Attribute value (unquoted) state
161attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
165attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
162attrValueUnquoted tag attrs name = do
166attrValueUnquoted tag attrs name = do
163 value <- takeTill (inClass "\x09\x0a\x0c >")
167 value <- takeTill (inClass "\x09\x0a\x0c >")
164 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
168 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
165 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
169 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
166
170
167−-- | 8.2.4.42: After attribute value (quoted) state
171+-- | /§8.2.4.42/: After attribute value (quoted) state
168afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
172afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
169afterAttrValueQuoted tag attrs name value =
173afterAttrValueQuoted tag attrs name value =
170 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
174 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
@@ -172,7 +176,7 @@ afterAttrValueQuoted tag attrs name value =
172 <|> (char '>' >> return (TagOpen tag attrs'))
176 <|> (char '>' >> return (TagOpen tag attrs'))
173 where attrs' = Attr name value : attrs
177 where attrs' = Attr name value : attrs
174
178
175−-- | 8.2.4.45: Markup declaration open state
179+-- | /§8.2.4.45/: Markup declaration open state
176markupDeclOpen :: Parser Token
180markupDeclOpen :: Parser Token
177markupDeclOpen =
181markupDeclOpen =
178 try comment
182 try comment
@@ -186,13 +190,13 @@ markupDeclOpen =
186 guard $ T.toLower s == "doctype"
190 guard $ T.toLower s == "doctype"
187 doctype
191 doctype
188
192
189−-- | 8.2.4.46: Comment start state
193+-- | /§8.2.4.46/: Comment start state
190commentStart :: Parser Token
194commentStart :: Parser Token
191commentStart = do
195commentStart = do
192 (char '-' >> commentStartDash)
196 (char '-' >> commentStartDash)
193 <|> (char '>' >> return (Comment mempty))
197 <|> (char '>' >> return (Comment mempty))
194
198
195−-- | 8.2.4.47: Comment start dash state
199+-- | /§8.2.4.47/: Comment start dash state
196commentStartDash :: Parser Token
200commentStartDash :: Parser Token
197commentStartDash =
201commentStartDash =
198 (char '-' >> commentEnd mempty)
202 (char '-' >> commentEnd mempty)
@@ -200,21 +204,21 @@ commentStartDash =
200 <|> (do c <- anyChar
204 <|> (do c <- anyChar
201 comment (B.singleton '-' <> B.singleton c) )
205 comment (B.singleton '-' <> B.singleton c) )
202
206
203−-- | 8.2.4.48: Comment state
207+-- | /§8.2.4.48/: Comment state
204comment :: Builder -> Parser Token
208comment :: Builder -> Parser Token
205comment content0 = do
209comment content0 = do
206 content <- B.fromText <$> takeWhile (notInClass "-")
210 content <- B.fromText <$> takeWhile (notInClass "-")
207 id $ (char '-' >> commentEndDash (content0 <> content))
211 id $ (char '-' >> commentEndDash (content0 <> content))
208 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
212 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
209
213
210−-- | 8.2.4.49: Comment end dash state
214+-- | /§8.2.4.49/: Comment end dash state
211commentEndDash :: Builder -> Parser Token
215commentEndDash :: Builder -> Parser Token
212commentEndDash content = do
216commentEndDash content = do
213 (char '-' >> commentEnd content)
217 (char '-' >> commentEnd content)
214 <|> (char '\x00' >> comment (content <> "-\xfffd"))
218 <|> (char '\x00' >> comment (content <> "-\xfffd"))
215 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
219 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
216
220
217−-- | 8.2.4.50: Comment end state
221+-- | /§8.2.4.50/: Comment end state
218commentEnd :: Builder -> Parser Token
222commentEnd :: Builder -> Parser Token
219commentEnd content = do
223commentEnd content = do
220 (char '>' >> return (Comment content))
224 (char '>' >> return (Comment content))
@@ -222,7 +226,7 @@ commentEnd content = do
222 -- <|> () TODO: other cases
226 -- <|> () TODO: other cases
223 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
227 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
224
228
225−-- | 8.2.4.52: DOCTYPE state
229+-- | /§8.2.4.52/: DOCTYPE state
226-- FIXME
230-- FIXME
227doctype :: Parser Token
231doctype :: Parser Token
228doctype = do
232doctype = do
@@ -230,7 +234,7 @@ doctype = do
230 char '>'
234 char '>'
231 return $ Doctype content
235 return $ Doctype content
232
236
233−-- | 8.2.4.44: Bogus comment state
237+-- | /§8.2.4.44/: Bogus comment state
234bogusComment :: Parser Token
238bogusComment :: Parser Token
235bogusComment = fail "Bogus comment"
239bogusComment = fail "Bogus comment"
236
240
html-parse.cabal+1−1
@@ -8,7 +8,7 @@ description:
8 .
8 .
9 The package targets similar use-cases to the venerable @tagsoup@ library,
9 The package targets similar use-cases to the venerable @tagsoup@ library,
10 but is significantly more efficient, achieving parsing speeds of over 50
10 but is significantly more efficient, achieving parsing speeds of over 50
11− megabytes per second.
11+ megabytes per second on modern hardware with and typical web documents.
12homepage: http://github.com/bgamari/html-parse
12homepage: http://github.com/bgamari/html-parse
13license: BSD3
13license: BSD3
14license-file: LICENSE
14license-file: LICENSE