@@ -40,6 +40,8 @@ import Data.Text.Lazy.Builder (Builder)
4040import qualified Data.Text.Lazy.Builder as B
4141import Prelude hiding (take, takeWhile)
4242
43+-- Section numbers refer to W3C HTML 5.2 specification.
44+
4345-- | A tag name (e.g. @body@)
4446type TagName = Text
4547
@@ -87,23 +89,23 @@ dataState = do
8789 then return $ ContentText content
8890 else char '<' >> tagOpen
8991
90−-- | /§8.2.4.3/: Tag open state
92+-- | /§8.2.4.6/: Tag open state
9193tagOpen :: Parser Token
9294tagOpen =
9395 (char '!' >> markupDeclOpen)
9496 <|> (char '/' >> endTagOpen)
95− <|> (char '?' >> bogusComment)
97+ <|> (char '?' >> bogusComment mempty)
9698 <|> tagNameOpen
9799 <|> other
98100 where
99101 other = do
100102 return $ ContentChar '<'
101103
102−-- | /§8.2.4.9/: End tag open state
104+-- | /§8.2.4.7/: End tag open state
103105endTagOpen :: Parser Token
104106endTagOpen = tagNameClose
105107
106−-- | /§8.2.4.10/: Tag name state: the open case
108+-- | /§8.2.4.8/: Tag name state: the open case
107109--
108110-- deviation: no lower-casing
109111tagNameOpen :: Parser Token
@@ -202,12 +204,12 @@ afterAttrValueQuoted tag attrs name value =
202204 <|> (char '>' >> return (TagOpen tag attrs'))
203205 where attrs' = Attr name value : attrs
204206
205−-- | /§8.2.4.45/: Markup declaration open state
207+-- | /§8.2.4.42/: Markup declaration open state
206208markupDeclOpen :: Parser Token
207209markupDeclOpen =
208210 try comment_
209211 <|> try docType
210− -- TODO: Fix the rest
212+ <|> bogusComment mempty
211213 where
212214 comment_ = string "--" >> commentStart
213215 docType = do
@@ -216,44 +218,78 @@ markupDeclOpen =
216218 guard $ T.toLower s == "doctype"
217219 doctype
218220
219−-- | /§8.2.4.46/: Comment start state
221+-- | /§8.2.4.43/: Comment start state
220222commentStart :: Parser Token
221223commentStart = do
222224 (char '-' >> commentStartDash)
223225 <|> (char '>' >> return (Comment mempty))
224226 <|> comment mempty
225227
226−-- | /§8.2.4.47/: Comment start dash state
228+-- | /§8.2.4.44/: Comment start dash state
227229commentStartDash :: Parser Token
228230commentStartDash =
229231 (char '-' >> commentEnd mempty)
230232 <|> (char '>' >> return (Comment mempty))
231− <|> (do c <- anyChar
232− comment (B.singleton '-' <> B.singleton c) )
233+ <|> (comment (B.singleton '-'))
233234
234−-- | /§8.2.4.48/: Comment state
235+-- | /§8.2.4.45/: Comment state
235236comment :: Builder -> Parser Token
236237comment content0 = do
237− content <- B.fromText <$> takeWhile (notInClass "-")
238− id $ (char '-' >> commentEndDash (content0 <> content))
238+ content <- B.fromText <$> takeWhile (notInClass "-\x00<")
239+ id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
240+ <|> (char '-' >> commentEndDash (content0 <> content))
239241 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
240242
241−-- | /§8.2.4.49/: Comment end dash state
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 <> "<"))
248+ <|> comment content
249+
250+-- | /§8.2.47/: Comment less-than sign bang state
251+commentLessThanBang :: Builder -> Parser Token
252+commentLessThanBang content =
253+ (char '-' >> commentLessThanBangDash content)
254+ <|> comment content
255+
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
261+
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
268+
269+-- | /§8.2.4.50/: Comment end dash state
242270commentEndDash :: Builder -> Parser Token
243271commentEndDash content = do
244272 (char '-' >> commentEnd content)
245− <|> (char '\x00' >> comment (content <> "-\xfffd"))
246− <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
273+ <|> (comment (content <> "-"))
247274
248−-- | /§8.2.4.50/: Comment end state
275+-- | /§8.2.4.51/: Comment end state
249276commentEnd :: Builder -> Parser Token
250277commentEnd content = do
251278 (char '>' >> return (Comment content))
252− <|> (char '\x00' >> comment (content <> "-\xfffd"))
253− -- <|> () TODO: other cases
254− <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
255−
256−-- | /§8.2.4.52/: DOCTYPE state
279+ <|> (char '!' >> commentEndBang content)
280+ <|> (char '-' >> commentEnd (content <> "-"))
281+ <|> (endOfInput >> return (Comment content))
282+ <|> (comment (content <> "--"))
283+
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 <> "--!"))
291+
292+-- | /§8.2.4.53/: DOCTYPE state
257293-- FIXME
258294doctype :: Parser Token
259295doctype = do
@@ -261,9 +297,13 @@ doctype = do
261297 _ <- char '>'
262298 return $ Doctype content
263299
264−-- | /§8.2.4.44/: Bogus comment state
265−bogusComment :: Parser Token
266−bogusComment = fail "Bogus comment"
300+-- | /§8.2.4.41/: Bogus comment state
301+bogusComment :: Builder -> Parser Token
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))
267307
268308-- | Parse a lazy list of tokens from strict 'Text'.
269309parseTokens :: Text -> [Token]