@@ -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
@@ -67,6 +69,10 @@ data Token
6769 | Doctype !Text
6870 deriving (Show, Ord, Eq, Generic)
6971
72+-- | This is a bit of a hack
73+endOfFileToken :: Token
74+endOfFileToken = ContentText ""
75+
7076-- | An attribute of a tag
7177data Attr = Attr !AttrName !AttrValue
7278 deriving (Show, Eq, Ord)
@@ -87,25 +93,25 @@ dataState = do
8793 then return $ ContentText content
8894 else char '<' >> tagOpen
8995
90−-- | /§8.2.4.3/: Tag open state
96+-- | /§8.2.4.6/: Tag open state
9197tagOpen :: Parser Token
9298tagOpen =
9399 (char '!' >> markupDeclOpen)
94100 <|> (char '/' >> endTagOpen)
95− <|> (char '?' >> bogusComment)
101+ <|> (char '?' >> bogusComment mempty)
96102 <|> tagNameOpen
97103 <|> other
98104 where
99105 other = do
100106 return $ ContentChar '<'
101107
102−-- | /§8.2.4.9/: End tag open state
108+-- | /§8.2.4.7/: End tag open state
103109endTagOpen :: Parser Token
104110endTagOpen = tagNameClose
105111
106−-- | /§8.2.4.10/: Tag name state: the open case
112+-- | /§8.2.4.8/: Tag name state: the open case
107113--
108−-- deviation: no lower-casing
114+-- deviation: no lower-casing, don't handle NULL characters
109115tagNameOpen :: Parser Token
110116tagNameOpen = do
111117 tag <- tagName'
@@ -121,20 +127,21 @@ tagNameClose = do
121127
122128-- | /§8.2.4.10/: Tag name state: common code
123129--
124−-- deviation: no lower-casing
130+-- deviation: no lower-casing, don't handle NULL characters
125131tagName' :: Parser Text
126132tagName' = do
127133 c <- peekChar'
128134 guard $ isAsciiUpper c || isAsciiLower c
129135 takeWhile $ notInClass "\x09\x0a\x0c /<>"
130136
131−-- | /§8.2.4.43/: Self-closing start tag state
137+-- | /§8.2.4.40/: Self-closing start tag state
132138selfClosingStartTag :: TagName -> [Attr] -> Parser Token
133139selfClosingStartTag tag attrs = do
134140 (char '>' >> return (TagSelfClose tag attrs))
141+ <|> (endOfInput >> return endOfFileToken)
135142 <|> beforeAttrName tag attrs
136143
137−-- | /§8.2.4.34/: Before attribute name state
144+-- | /§8.2.4.32/: Before attribute name state
138145--
139146-- deviation: no lower-casing
140147beforeAttrName :: TagName -> [Attr] -> Parser Token
@@ -145,26 +152,29 @@ beforeAttrName tag attrs = do
145152 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
146153 <|> attrName tag attrs
147154
148−-- | /§8.2.4.35/: Attribute name state
155+-- | /§8.2.4.33/: Attribute name state
149156attrName :: TagName -> [Attr] -> Parser Token
150157attrName tag attrs = do
151− name <- takeWhile $ notInClass "\x09\x0a\x0c /=<>\x00"
152− id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
153− <|> (char '/' >> selfClosingStartTag tag attrs)
158+ name <- takeWhile $ notInClass "\x09\x0a\x0c /=>"
159+ id $ (endOfInput >> afterAttrName tag attrs name)
154160 <|> (char '=' >> beforeAttrValue tag attrs name)
155− <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
161+ <|> try (do mc <- peekChar
162+ case mc of
163+ Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name
164+ _ -> empty)
156165 -- <|> -- TODO: NULL
157166
158−-- | /§8.2.4.36/: After attribute name state
167+-- | /§8.2.4.34/: After attribute name state
159168afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
160169afterAttrName tag attrs name = do
161170 skipWhile $ inClass "\x09\x0a\x0c "
162171 id $ (char '/' >> selfClosingStartTag tag attrs)
163172 <|> (char '=' >> beforeAttrValue tag attrs name)
164173 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
174+ <|> (endOfInput >> return endOfFileToken)
165175 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
166176
167−-- | /§8.2.4.37/: Before attribute value state
177+-- | /§8.2.4.35/: Before attribute value state
168178beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
169179beforeAttrValue tag attrs name = do
170180 skipWhile $ inClass "\x09\x0a\x0c "
@@ -173,41 +183,51 @@ beforeAttrValue tag attrs name = do
173183 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
174184 <|> attrValueUnquoted tag attrs name
175185
176−-- | /§8.2.4.38/: Attribute value (double-quoted) state
186+-- | /§8.2.4.36/: Attribute value (double-quoted) state
177187attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
178188attrValueDQuoted tag attrs name = do
179189 value <- takeWhile (/= '"')
180190 _ <- char '"'
181191 afterAttrValueQuoted tag attrs name value
182192
183−-- | /§8.2.4.39/: Attribute value (single-quoted) state
193+-- | /§8.2.4.37/: Attribute value (single-quoted) state
184194attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
185195attrValueSQuoted tag attrs name = do
186196 value <- takeWhile (/= '\'')
187197 _ <- char '\''
188198 afterAttrValueQuoted tag attrs name value
189199
190−-- | /§8.2.4.40/: Attribute value (unquoted) state
200+-- | /§8.2.4.38/: Attribute value (unquoted) state
191201attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
192202attrValueUnquoted tag attrs name = do
193203 value <- takeTill (inClass "\x09\x0a\x0c >")
194204 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
195205 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
206+ <|> (endOfInput >> return endOfFileToken)
196207
197−-- | /§8.2.4.42/: After attribute value (quoted) state
208+-- | /§8.2.4.39/: After attribute value (quoted) state
198209afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
199210afterAttrValueQuoted tag attrs name value =
200211 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
201212 <|> (char '/' >> selfClosingStartTag tag attrs')
202213 <|> (char '>' >> return (TagOpen tag attrs'))
214+ <|> (endOfInput >> return endOfFileToken)
203215 where attrs' = Attr name value : attrs
204216
205−-- | /§8.2.4.45/: Markup declaration open state
217+-- | /§8.2.4.41/: Bogus comment state
218+bogusComment :: Builder -> Parser Token
219+bogusComment content = do
220+ (char '>' >> return (Comment content))
221+ <|> (endOfInput >> return (Comment content))
222+ <|> (char '\x00' >> bogusComment (content <> "\xfffd"))
223+ <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))
224+
225+-- | /§8.2.4.42/: Markup declaration open state
206226markupDeclOpen :: Parser Token
207227markupDeclOpen =
208228 try comment_
209229 <|> try docType
210− -- TODO: Fix the rest
230+ <|> bogusComment mempty
211231 where
212232 comment_ = string "--" >> commentStart
213233 docType = do
@@ -216,44 +236,81 @@ markupDeclOpen =
216236 guard $ T.toLower s == "doctype"
217237 doctype
218238
219−-- | /§8.2.4.46/: Comment start state
239+-- | /§8.2.4.43/: Comment start state
220240commentStart :: Parser Token
221241commentStart = do
222242 (char '-' >> commentStartDash)
223243 <|> (char '>' >> return (Comment mempty))
224244 <|> comment mempty
225245
226−-- | /§8.2.4.47/: Comment start dash state
246+-- | /§8.2.4.44/: Comment start dash state
227247commentStartDash :: Parser Token
228248commentStartDash =
229249 (char '-' >> commentEnd mempty)
230250 <|> (char '>' >> return (Comment mempty))
231− <|> (do c <- anyChar
232− comment (B.singleton '-' <> B.singleton c) )
251+ <|> (endOfInput >> return (Comment mempty))
252+ <|> (comment (B.singleton '-'))
233253
234−-- | /§8.2.4.48/: Comment state
254+-- | /§8.2.4.45/: Comment state
235255comment :: Builder -> Parser Token
236256comment content0 = do
237− content <- B.fromText <$> takeWhile (notInClass "-")
238− id $ (char '-' >> commentEndDash (content0 <> content))
257+ content <- B.fromText <$> takeWhile (notInClass "-\x00<")
258+ id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
259+ <|> (char '-' >> commentEndDash (content0 <> content))
239260 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
240−
241−-- | /§8.2.4.49/: Comment end dash state
261+ <|> (endOfInput >> return (Comment $ content0 <> content))
262+
263+-- | /§8.2.46/: Comment less-than sign state
264+commentLessThan :: Builder -> Parser Token
265+commentLessThan content =
266+ (char '!' >> commentLessThanBang (content <> "!"))
267+ <|> (char '<' >> commentLessThan (content <> "<"))
268+ <|> comment content
269+
270+-- | /§8.2.47/: Comment less-than sign bang state
271+commentLessThanBang :: Builder -> Parser Token
272+commentLessThanBang content =
273+ (char '-' >> commentLessThanBangDash content)
274+ <|> comment content
275+
276+-- | /§8.2.48/: Comment less-than sign bang dash state
277+commentLessThanBangDash :: Builder -> Parser Token
278+commentLessThanBangDash content =
279+ (char '-' >> commentLessThanBangDashDash content)
280+ <|> commentEndDash content
281+
282+-- | /§8.2.49/: Comment less-than sign bang dash dash state
283+commentLessThanBangDashDash :: Builder -> Parser Token
284+commentLessThanBangDashDash content =
285+ (char '>' >> comment content)
286+ <|> (endOfInput >> comment content)
287+ <|> commentEnd content
288+
289+-- | /§8.2.4.50/: Comment end dash state
242290commentEndDash :: Builder -> Parser Token
243291commentEndDash content = do
244292 (char '-' >> commentEnd content)
245− <|> (char '\x00' >> comment (content <> "-\xfffd"))
246− <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
293+ <|> (endOfInput >> return (Comment content))
294+ <|> (comment (content <> "-"))
247295
248−-- | /§8.2.4.50/: Comment end state
296+-- | /§8.2.4.51/: Comment end state
249297commentEnd :: Builder -> Parser Token
250298commentEnd content = do
251299 (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
300+ <|> (char '!' >> commentEndBang content)
301+ <|> (char '-' >> commentEnd (content <> "-"))
302+ <|> (endOfInput >> return (Comment content))
303+ <|> (comment (content <> "--"))
304+
305+-- | /§8.2.4.52/: Comment end bang state
306+commentEndBang :: Builder -> Parser Token
307+commentEndBang content = do
308+ (char '-' >> commentEndDash (content <> "--!"))
309+ <|> (char '>' >> return (Comment content))
310+ <|> (endOfInput >> return (Comment content))
311+ <|> (comment (content <> "--!"))
312+
313+-- | /§8.2.4.53/: DOCTYPE state
257314-- FIXME
258315doctype :: Parser Token
259316doctype = do
@@ -261,10 +318,6 @@ doctype = do
261318 _ <- char '>'
262319 return $ Doctype content
263320
264−-- | /§8.2.4.44/: Bogus comment state
265−bogusComment :: Parser Token
266−bogusComment = fail "Bogus comment"
267−
268321-- | Parse a lazy list of tokens from strict 'Text'.
269322parseTokens :: Text -> [Token]
270323parseTokens = unfoldr f