@@ -40,6 +40,8 @@ import Data.Text.Lazy.Builder (Builder)
40import qualified Data.Text.Lazy.Builder as B
40import qualified Data.Text.Lazy.Builder as B
41import Prelude hiding (take, takeWhile)
41import Prelude hiding (take, takeWhile)
43+-- Section numbers refer to W3C HTML 5.2 specification.
43-- | A tag name (e.g. @body@)
45-- | A tag name (e.g. @body@)
44type TagName = Text
46type TagName = Text
@@ -87,23 +89,23 @@ dataState = do
87 then return $ ContentText content
89 then return $ ContentText content
88 else char '<' >> tagOpen
90 else char '<' >> tagOpen
90−-- | /§8.2.4.3/: Tag open state
92+-- | /§8.2.4.6/: Tag open state
91tagOpen :: Parser Token
93tagOpen :: Parser Token
93 (char '!' >> markupDeclOpen)
95 (char '!' >> markupDeclOpen)
94 <|> (char '/' >> endTagOpen)
96 <|> (char '/' >> endTagOpen)
95− <|> (char '?' >> bogusComment)
97+ <|> (char '?' >> bogusComment mempty)
96 <|> tagNameOpen
98 <|> tagNameOpen
99 other = do
101 other = do
100 return $ ContentChar '<'
102 return $ ContentChar '<'
102−-- | /§8.2.4.9/: End tag open state
104+-- | /§8.2.4.7/: End tag open state
103endTagOpen :: Parser Token
105endTagOpen :: Parser Token
104endTagOpen = tagNameClose
106endTagOpen = tagNameClose
106−-- | /§8.2.4.10/: Tag name state: the open case
108+-- | /§8.2.4.8/: Tag name state: the open case
108-- deviation: no lower-casing
110-- deviation: no lower-casing
109tagNameOpen :: Parser Token
111tagNameOpen :: Parser Token
@@ -202,12 +204,12 @@ afterAttrValueQuoted tag attrs name value =
202 <|> (char '>' >> return (TagOpen tag attrs'))
204 <|> (char '>' >> return (TagOpen tag attrs'))
203 where attrs' = Attr name value : attrs
205 where attrs' = Attr name value : attrs
205−-- | /§8.2.4.45/: Markup declaration open state
207+-- | /§8.2.4.42/: Markup declaration open state
206markupDeclOpen :: Parser Token
208markupDeclOpen :: Parser Token
207markupDeclOpen =
209markupDeclOpen =
208 try comment_
210 try comment_
209 <|> try docType
211 <|> try docType
210− -- TODO: Fix the rest
212+ <|> bogusComment mempty
212 comment_ = string "--" >> commentStart
214 comment_ = string "--" >> commentStart
213 docType = do
215 docType = do
@@ -216,44 +218,78 @@ markupDeclOpen =
216 guard $ T.toLower s == "doctype"
218 guard $ T.toLower s == "doctype"
219−-- | /§8.2.4.46/: Comment start state
221+-- | /§8.2.4.43/: Comment start state
220commentStart :: Parser Token
222commentStart :: Parser Token
221commentStart = do
223commentStart = do
222 (char '-' >> commentStartDash)
224 (char '-' >> commentStartDash)
223 <|> (char '>' >> return (Comment mempty))
225 <|> (char '>' >> return (Comment mempty))
224 <|> comment mempty
226 <|> comment mempty
226−-- | /§8.2.4.47/: Comment start dash state
228+-- | /§8.2.4.44/: Comment start dash state
227commentStartDash :: Parser Token
229commentStartDash :: Parser Token
228commentStartDash =
230commentStartDash =
229 (char '-' >> commentEnd mempty)
231 (char '-' >> commentEnd mempty)
230 <|> (char '>' >> return (Comment mempty))
232 <|> (char '>' >> return (Comment mempty))
231− <|> (do c <- anyChar
232− comment (B.singleton '-' <> B.singleton c) )
233+ <|> (comment (B.singleton '-'))
234−-- | /§8.2.4.48/: Comment state
235+-- | /§8.2.4.45/: Comment state
235comment :: Builder -> Parser Token
236comment :: Builder -> Parser Token
236comment content0 = do
237comment content0 = do
237− content <- B.fromText <$> takeWhile (notInClass "-")
238+ content <- B.fromText <$> takeWhile (notInClass "-\x00<")
239+ id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
238− id $ (char '-' >> commentEndDash (content0 <> content))
240+ <|> (char '-' >> commentEndDash (content0 <> content))
239 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
241 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
243+-- | /§8.2.46/: Comment less-than sign state
244+commentLessThan :: Builder -> Parser Token
245+commentLessThan content =
246+ (char '!' >> commentLessThanBang (content <> "!"))
247+ <|> (char '<' >> commentLessThan (content <> "<"))
250+-- | /§8.2.47/: Comment less-than sign bang state
251+commentLessThanBang :: Builder -> Parser Token
252+commentLessThanBang content =
253+ (char '-' >> commentLessThanBangDash content)
256+-- | /§8.2.48/: Comment less-than sign bang dash state
257+commentLessThanBangDash :: Builder -> Parser Token
258+commentLessThanBangDash content =
259+ (char '-' >> commentLessThanBangDashDash content)
260+ <|> commentEndDash content
262+-- | /§8.2.49/: Comment less-than sign bang dash dash state
263+commentLessThanBangDashDash :: Builder -> Parser Token
264+commentLessThanBangDashDash content =
265+ (char '>' >> comment content)
266+ <|> (endOfInput >> comment content)
267+ <|> commentEnd content
241−-- | /§8.2.4.49/: Comment end dash state
269+-- | /§8.2.4.50/: Comment end dash state
242commentEndDash :: Builder -> Parser Token
270commentEndDash :: Builder -> Parser Token
243commentEndDash content = do
271commentEndDash content = do
244 (char '-' >> commentEnd content)
272 (char '-' >> commentEnd content)
245− <|> (char '\x00' >> comment (content <> "-\xfffd"))
273+ <|> (comment (content <> "-"))
246− <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
248−-- | /§8.2.4.50/: Comment end state
275+-- | /§8.2.4.51/: Comment end state
249commentEnd :: Builder -> Parser Token
276commentEnd :: Builder -> Parser Token
250commentEnd content = do
277commentEnd content = do
251 (char '>' >> return (Comment content))
278 (char '>' >> return (Comment content))
252− <|> (char '\x00' >> comment (content <> "-\xfffd"))
279+ <|> (char '!' >> commentEndBang content)
253− -- <|> () TODO: other cases
280+ <|> (char '-' >> commentEnd (content <> "-"))
281+ <|> (endOfInput >> return (Comment content))
254− <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
282+ <|> (comment (content <> "--"))
284+-- | /§8.2.4.52/: Comment end bang state
285+commentEndBang :: Builder -> Parser Token
286+commentEndBang content = do
287+ (char '-' >> commentEndDash (content <> "--!"))
288+ <|> (char '>' >> return (Comment content))
289+ <|> (endOfInput >> return (Comment content))
290+ <|> (comment (content <> "--!"))
256−-- | /§8.2.4.52/: DOCTYPE state
292+-- | /§8.2.4.53/: DOCTYPE state
258doctype :: Parser Token
294doctype :: Parser Token
259doctype = do
295doctype = do
@@ -261,9 +297,13 @@ doctype = do
261 _ <- char '>'
297 _ <- char '>'
262 return $ Doctype content
298 return $ Doctype content
264−-- | /§8.2.4.44/: Bogus comment state
300+-- | /§8.2.4.41/: Bogus comment state
265−bogusComment :: Parser Token
301+bogusComment :: Builder -> Parser Token
266−bogusComment = fail "Bogus comment"
302+bogusComment content = do
303+ (char '>' >> return (Comment content))
304+ <|> (endOfInput >> return (Comment content))
305+ <|> (char '\x00' >> bogusComment (content <> "\xfffd"))
306+ <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))
268-- | Parse a lazy list of tokens from strict 'Text'.
308-- | Parse a lazy list of tokens from strict 'Text'.
269parseTokens :: Text -> [Token]
309parseTokens :: Text -> [Token]