@@ -1,6 +1,10 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE DeriveGeneric #-}
33
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+--
48module Text.HTML.Parser
59 ( TagName, AttrName, AttrValue
610 , Token(..)
@@ -51,11 +55,11 @@ instance NFData Token where
5155 rnf (Comment b) = rnf $ B.toLazyText b
5256 rnf _ = ()
5357
54−-- | Start in the data state.
58+-- | Parse a single 'Token'.
5559token :: Parser Token
56−token = dataState
60+token = dataState -- Start in the data state.
5761
58−-- | 8.2.4.1: Data state
62+-- | /§8.2.4.1/: Data state
5963dataState :: Parser Token
6064dataState = do
6165 content <- takeWhile (/= '<')
@@ -63,7 +67,7 @@ dataState = do
6367 then return $ ContentText content
6468 else char '<' >> tagOpen
6569
66−-- | 8.2.4.3: Tag open state
70+-- | /§8.2.4.3/: Tag open state
6771tagOpen :: Parser Token
6872tagOpen =
6973 (char '!' >> markupDeclOpen)
@@ -80,7 +84,7 @@ tagOpen =
8084 other = do
8185 return $ ContentChar '<'
8286
83−-- | 8.2.4.9: End tag open state
87+-- | /§8.2.4.9/: End tag open state
8488-- TODO: This isn't right
8589endTagOpen :: Parser Token
8690endTagOpen = do
@@ -88,7 +92,7 @@ endTagOpen = do
8892 char '>'
8993 return $ TagClose name
9094
91−-- | 8.2.4.10: Tag name state
95+-- | /§8.2.4.10/: Tag name state
9296--
9397-- deviation: no lower-casing
9498tagName :: Parser Token
@@ -98,13 +102,13 @@ tagName = do
98102 <|> (char '/' >> selfClosingStartTag tag [])
99103 <|> (char '>' >> return (TagOpen tag []))
100104
101−-- | 8.2.4.43: Self-closing start tag state
105+-- | /§8.2.4.43/: Self-closing start tag state
102106selfClosingStartTag :: TagName -> [Attr] -> Parser Token
103107selfClosingStartTag tag attrs = do
104108 (char '>' >> return (TagOpen tag attrs))
105109 <|> beforeAttrName tag attrs
106110
107−-- | 8.2.4.34: Before attribute name state
111+-- | /§8.2.4.34/: Before attribute name state
108112--
109113-- deviation: no lower-casing
110114beforeAttrName :: TagName -> [Attr] -> Parser Token
@@ -115,7 +119,7 @@ beforeAttrName tag attrs = do
115119 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
116120 <|> attrName tag attrs
117121
118−-- | 8.2.4.35: Attribute name state
122+-- | /§8.2.4.35/: Attribute name state
119123attrName :: TagName -> [Attr] -> Parser Token
120124attrName tag attrs = do
121125 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
@@ -125,7 +129,7 @@ attrName tag attrs = do
125129 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
126130 -- <|> -- TODO: NULL
127131
128−-- | 8.2.4.36: After attribute name state
132+-- | /§8.2.4.36/: After attribute name state
129133afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
130134afterAttrName tag attrs name = do
131135 skipWhile $ inClass "\x09\x0a\x0c "
@@ -134,7 +138,7 @@ afterAttrName tag attrs name = do
134138 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
135139 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
136140
137−-- | 8.2.4.37: Before attribute value state
141+-- | /§8.2.4.37/: Before attribute value state
138142beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
139143beforeAttrValue tag attrs name = do
140144 skipWhile $ inClass "\x09\x0a\x0c "
@@ -143,28 +147,28 @@ beforeAttrValue tag attrs name = do
143147 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
144148 <|> attrValueUnquoted tag attrs name
145149
146−-- | 8.2.4.38: Attribute value (double-quoted) state
150+-- | /§8.2.4.38/: Attribute value (double-quoted) state
147151attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
148152attrValueDQuoted tag attrs name = do
149153 value <- takeWhile (/= '"')
150154 char '"'
151155 afterAttrValueQuoted tag attrs name value
152156
153−-- | 8.2.4.39: Attribute value (single-quoted) state
157+-- | /§8.2.4.39/: Attribute value (single-quoted) state
154158attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
155159attrValueSQuoted tag attrs name = do
156160 value <- takeWhile (/= '\'')
157161 char '\''
158162 afterAttrValueQuoted tag attrs name value
159163
160−-- | 8.2.4.40: Attribute value (unquoted) state
164+-- | /§8.2.4.40/: Attribute value (unquoted) state
161165attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
162166attrValueUnquoted tag attrs name = do
163167 value <- takeTill (inClass "\x09\x0a\x0c >")
164168 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
165169 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
166170
167−-- | 8.2.4.42: After attribute value (quoted) state
171+-- | /§8.2.4.42/: After attribute value (quoted) state
168172afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
169173afterAttrValueQuoted tag attrs name value =
170174 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
@@ -172,7 +176,7 @@ afterAttrValueQuoted tag attrs name value =
172176 <|> (char '>' >> return (TagOpen tag attrs'))
173177 where attrs' = Attr name value : attrs
174178
175−-- | 8.2.4.45: Markup declaration open state
179+-- | /§8.2.4.45/: Markup declaration open state
176180markupDeclOpen :: Parser Token
177181markupDeclOpen =
178182 try comment
@@ -186,13 +190,13 @@ markupDeclOpen =
186190 guard $ T.toLower s == "doctype"
187191 doctype
188192
189−-- | 8.2.4.46: Comment start state
193+-- | /§8.2.4.46/: Comment start state
190194commentStart :: Parser Token
191195commentStart = do
192196 (char '-' >> commentStartDash)
193197 <|> (char '>' >> return (Comment mempty))
194198
195−-- | 8.2.4.47: Comment start dash state
199+-- | /§8.2.4.47/: Comment start dash state
196200commentStartDash :: Parser Token
197201commentStartDash =
198202 (char '-' >> commentEnd mempty)
@@ -200,21 +204,21 @@ commentStartDash =
200204 <|> (do c <- anyChar
201205 comment (B.singleton '-' <> B.singleton c) )
202206
203−-- | 8.2.4.48: Comment state
207+-- | /§8.2.4.48/: Comment state
204208comment :: Builder -> Parser Token
205209comment content0 = do
206210 content <- B.fromText <$> takeWhile (notInClass "-")
207211 id $ (char '-' >> commentEndDash (content0 <> content))
208212 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
209213
210−-- | 8.2.4.49: Comment end dash state
214+-- | /§8.2.4.49/: Comment end dash state
211215commentEndDash :: Builder -> Parser Token
212216commentEndDash content = do
213217 (char '-' >> commentEnd content)
214218 <|> (char '\x00' >> comment (content <> "-\xfffd"))
215219 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
216220
217−-- | 8.2.4.50: Comment end state
221+-- | /§8.2.4.50/: Comment end state
218222commentEnd :: Builder -> Parser Token
219223commentEnd content = do
220224 (char '>' >> return (Comment content))
@@ -222,7 +226,7 @@ commentEnd content = do
222226 -- <|> () TODO: other cases
223227 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
224228
225−-- | 8.2.4.52: DOCTYPE state
229+-- | /§8.2.4.52/: DOCTYPE state
226230-- FIXME
227231doctype :: Parser Token
228232doctype = do
@@ -230,7 +234,7 @@ doctype = do
230234 char '>'
231235 return $ Doctype content
232236
233−-- | 8.2.4.44: Bogus comment state
237+-- | /§8.2.4.44/: Bogus comment state
234238bogusComment :: Parser Token
235239bogusComment = fail "Bogus comment"
236240