@@ -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
@@ -67,6 +69,10 @@ data Token
67 | Doctype !Text
69 | Doctype !Text
68 deriving (Show, Ord, Eq, Generic)
70 deriving (Show, Ord, Eq, Generic)
72+-- | This is a bit of a hack
73+endOfFileToken :: Token
74+endOfFileToken = ContentText ""
70-- | An attribute of a tag
76-- | An attribute of a tag
71data Attr = Attr !AttrName !AttrValue
77data Attr = Attr !AttrName !AttrValue
72 deriving (Show, Eq, Ord)
78 deriving (Show, Eq, Ord)
@@ -87,25 +93,25 @@ dataState = do
87 then return $ ContentText content
93 then return $ ContentText content
88 else char '<' >> tagOpen
94 else char '<' >> tagOpen
90−-- | /§8.2.4.3/: Tag open state
96+-- | /§8.2.4.6/: Tag open state
91tagOpen :: Parser Token
97tagOpen :: Parser Token
93 (char '!' >> markupDeclOpen)
99 (char '!' >> markupDeclOpen)
94 <|> (char '/' >> endTagOpen)
100 <|> (char '/' >> endTagOpen)
95− <|> (char '?' >> bogusComment)
101+ <|> (char '?' >> bogusComment mempty)
96 <|> tagNameOpen
102 <|> tagNameOpen
97 <|> other
103 <|> other
99 other = do
105 other = do
100 return $ ContentChar '<'
106 return $ ContentChar '<'
102−-- | /§8.2.4.9/: End tag open state
108+-- | /§8.2.4.7/: End tag open state
103endTagOpen :: Parser Token
109endTagOpen :: Parser Token
104endTagOpen = tagNameClose
110endTagOpen = tagNameClose
106−-- | /§8.2.4.10/: Tag name state: the open case
112+-- | /§8.2.4.8/: Tag name state: the open case
108−-- deviation: no lower-casing
114+-- deviation: no lower-casing, don't handle NULL characters
109tagNameOpen :: Parser Token
115tagNameOpen :: Parser Token
110tagNameOpen = do
116tagNameOpen = do
111 tag <- tagName'
117 tag <- tagName'
@@ -121,20 +127,21 @@ tagNameClose = do
122-- | /§8.2.4.10/: Tag name state: common code
128-- | /§8.2.4.10/: Tag name state: common code
124−-- deviation: no lower-casing
130+-- deviation: no lower-casing, don't handle NULL characters
125tagName' :: Parser Text
131tagName' :: Parser Text
126tagName' = do
132tagName' = do
127 c <- peekChar'
133 c <- peekChar'
128 guard $ isAsciiUpper c || isAsciiLower c
134 guard $ isAsciiUpper c || isAsciiLower c
129 takeWhile $ notInClass "\x09\x0a\x0c /<>"
135 takeWhile $ notInClass "\x09\x0a\x0c /<>"
131−-- | /§8.2.4.43/: Self-closing start tag state
137+-- | /§8.2.4.40/: Self-closing start tag state
132selfClosingStartTag :: TagName -> [Attr] -> Parser Token
138selfClosingStartTag :: TagName -> [Attr] -> Parser Token
133selfClosingStartTag tag attrs = do
139selfClosingStartTag tag attrs = do
134 (char '>' >> return (TagSelfClose tag attrs))
140 (char '>' >> return (TagSelfClose tag attrs))
141+ <|> (endOfInput >> return endOfFileToken)
135 <|> beforeAttrName tag attrs
142 <|> beforeAttrName tag attrs
137−-- | /§8.2.4.34/: Before attribute name state
144+-- | /§8.2.4.32/: Before attribute name state
139-- deviation: no lower-casing
146-- deviation: no lower-casing
140beforeAttrName :: TagName -> [Attr] -> Parser Token
147beforeAttrName :: TagName -> [Attr] -> Parser Token
@@ -145,26 +152,29 @@ beforeAttrName tag attrs = do
145 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
152 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
146 <|> attrName tag attrs
153 <|> attrName tag attrs
148−-- | /§8.2.4.35/: Attribute name state
155+-- | /§8.2.4.33/: Attribute name state
149attrName :: TagName -> [Attr] -> Parser Token
156attrName :: TagName -> [Attr] -> Parser Token
150attrName tag attrs = do
157attrName tag attrs = do
151− name <- takeWhile $ notInClass "\x09\x0a\x0c /=<>\x00"
158+ name <- takeWhile $ notInClass "\x09\x0a\x0c /=>"
152− id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
159+ id $ (endOfInput >> afterAttrName tag attrs name)
153− <|> (char '/' >> selfClosingStartTag tag attrs)
154 <|> (char '=' >> beforeAttrValue tag attrs name)
160 <|> (char '=' >> beforeAttrValue tag attrs name)
155− <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
161+ <|> try (do mc <- peekChar
163+ Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name
156 -- <|> -- TODO: NULL
165 -- <|> -- TODO: NULL
158−-- | /§8.2.4.36/: After attribute name state
167+-- | /§8.2.4.34/: After attribute name state
159afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
168afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
160afterAttrName tag attrs name = do
169afterAttrName tag attrs name = do
161 skipWhile $ inClass "\x09\x0a\x0c "
170 skipWhile $ inClass "\x09\x0a\x0c "
162 id $ (char '/' >> selfClosingStartTag tag attrs)
171 id $ (char '/' >> selfClosingStartTag tag attrs)
163 <|> (char '=' >> beforeAttrValue tag attrs name)
172 <|> (char '=' >> beforeAttrValue tag attrs name)
164 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
173 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
174+ <|> (endOfInput >> return endOfFileToken)
165 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
175 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
167−-- | /§8.2.4.37/: Before attribute value state
177+-- | /§8.2.4.35/: Before attribute value state
168beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
178beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
169beforeAttrValue tag attrs name = do
179beforeAttrValue tag attrs name = do
170 skipWhile $ inClass "\x09\x0a\x0c "
180 skipWhile $ inClass "\x09\x0a\x0c "
@@ -173,41 +183,51 @@ beforeAttrValue tag attrs name = do
173 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
183 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
174 <|> attrValueUnquoted tag attrs name
184 <|> attrValueUnquoted tag attrs name
176−-- | /§8.2.4.38/: Attribute value (double-quoted) state
186+-- | /§8.2.4.36/: Attribute value (double-quoted) state
177attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
187attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
178attrValueDQuoted tag attrs name = do
188attrValueDQuoted tag attrs name = do
179 value <- takeWhile (/= '"')
189 value <- takeWhile (/= '"')
180 _ <- char '"'
190 _ <- char '"'
181 afterAttrValueQuoted tag attrs name value
191 afterAttrValueQuoted tag attrs name value
183−-- | /§8.2.4.39/: Attribute value (single-quoted) state
193+-- | /§8.2.4.37/: Attribute value (single-quoted) state
184attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
194attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
185attrValueSQuoted tag attrs name = do
195attrValueSQuoted tag attrs name = do
186 value <- takeWhile (/= '\'')
196 value <- takeWhile (/= '\'')
187 _ <- char '\''
197 _ <- char '\''
188 afterAttrValueQuoted tag attrs name value
198 afterAttrValueQuoted tag attrs name value
190−-- | /§8.2.4.40/: Attribute value (unquoted) state
200+-- | /§8.2.4.38/: Attribute value (unquoted) state
191attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
201attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
192attrValueUnquoted tag attrs name = do
202attrValueUnquoted tag attrs name = do
193 value <- takeTill (inClass "\x09\x0a\x0c >")
203 value <- takeTill (inClass "\x09\x0a\x0c >")
194 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
204 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
195 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
205 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
206+ <|> (endOfInput >> return endOfFileToken)
197−-- | /§8.2.4.42/: After attribute value (quoted) state
208+-- | /§8.2.4.39/: After attribute value (quoted) state
198afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
209afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
199afterAttrValueQuoted tag attrs name value =
210afterAttrValueQuoted tag attrs name value =
200 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
211 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
201 <|> (char '/' >> selfClosingStartTag tag attrs')
212 <|> (char '/' >> selfClosingStartTag tag attrs')
202 <|> (char '>' >> return (TagOpen tag attrs'))
213 <|> (char '>' >> return (TagOpen tag attrs'))
214+ <|> (endOfInput >> return endOfFileToken)
203 where attrs' = Attr name value : attrs
215 where attrs' = Attr name value : attrs
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))
205−-- | /§8.2.4.45/: Markup declaration open state
225+-- | /§8.2.4.42/: Markup declaration open state
206markupDeclOpen :: Parser Token
226markupDeclOpen :: Parser Token
207markupDeclOpen =
227markupDeclOpen =
208 try comment_
228 try comment_
209 <|> try docType
229 <|> try docType
210− -- TODO: Fix the rest
230+ <|> bogusComment mempty
212 comment_ = string "--" >> commentStart
232 comment_ = string "--" >> commentStart
213 docType = do
233 docType = do
@@ -216,44 +236,81 @@ markupDeclOpen =
216 guard $ T.toLower s == "doctype"
236 guard $ T.toLower s == "doctype"
219−-- | /§8.2.4.46/: Comment start state
239+-- | /§8.2.4.43/: Comment start state
220commentStart :: Parser Token
240commentStart :: Parser Token
221commentStart = do
241commentStart = do
222 (char '-' >> commentStartDash)
242 (char '-' >> commentStartDash)
223 <|> (char '>' >> return (Comment mempty))
243 <|> (char '>' >> return (Comment mempty))
224 <|> comment mempty
244 <|> comment mempty
226−-- | /§8.2.4.47/: Comment start dash state
246+-- | /§8.2.4.44/: Comment start dash state
227commentStartDash :: Parser Token
247commentStartDash :: Parser Token
228commentStartDash =
248commentStartDash =
229 (char '-' >> commentEnd mempty)
249 (char '-' >> commentEnd mempty)
230 <|> (char '>' >> return (Comment mempty))
250 <|> (char '>' >> return (Comment mempty))
231− <|> (do c <- anyChar
251+ <|> (endOfInput >> return (Comment mempty))
232− comment (B.singleton '-' <> B.singleton c) )
252+ <|> (comment (B.singleton '-'))
234−-- | /§8.2.4.48/: Comment state
254+-- | /§8.2.4.45/: Comment state
235comment :: Builder -> Parser Token
255comment :: Builder -> Parser Token
236comment content0 = do
256comment content0 = do
237− content <- B.fromText <$> takeWhile (notInClass "-")
257+ content <- B.fromText <$> takeWhile (notInClass "-\x00<")
258+ id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
238− id $ (char '-' >> commentEndDash (content0 <> content))
259+ <|> (char '-' >> commentEndDash (content0 <> content))
239 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
260 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
240−
261+ <|> (endOfInput >> return (Comment $ content0 <> content))
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 <> "<"))
270+-- | /§8.2.47/: Comment less-than sign bang state
271+commentLessThanBang :: Builder -> Parser Token
272+commentLessThanBang content =
273+ (char '-' >> commentLessThanBangDash content)
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
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
241−-- | /§8.2.4.49/: Comment end dash state
289+-- | /§8.2.4.50/: Comment end dash state
242commentEndDash :: Builder -> Parser Token
290commentEndDash :: Builder -> Parser Token
243commentEndDash content = do
291commentEndDash content = do
244 (char '-' >> commentEnd content)
292 (char '-' >> commentEnd content)
245− <|> (char '\x00' >> comment (content <> "-\xfffd"))
293+ <|> (endOfInput >> return (Comment content))
246− <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
294+ <|> (comment (content <> "-"))
248−-- | /§8.2.4.50/: Comment end state
296+-- | /§8.2.4.51/: Comment end state
249commentEnd :: Builder -> Parser Token
297commentEnd :: Builder -> Parser Token
250commentEnd content = do
298commentEnd content = do
251 (char '>' >> return (Comment content))
299 (char '>' >> return (Comment content))
252− <|> (char '\x00' >> comment (content <> "-\xfffd"))
300+ <|> (char '!' >> commentEndBang content)
253− -- <|> () TODO: other cases
301+ <|> (char '-' >> commentEnd (content <> "-"))
302+ <|> (endOfInput >> return (Comment content))
254− <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
303+ <|> (comment (content <> "--"))
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 <> "--!"))
256−-- | /§8.2.4.52/: DOCTYPE state
313+-- | /§8.2.4.53/: DOCTYPE state
258doctype :: Parser Token
315doctype :: Parser Token
259doctype = do
316doctype = do
@@ -261,10 +318,6 @@ doctype = do
261 _ <- char '>'
318 _ <- char '>'
262 return $ Doctype content
319 return $ Doctype content
264−-- | /§8.2.4.44/: Bogus comment state
265−bogusComment :: Parser Token
266−bogusComment = fail "Bogus comment"
268-- | Parse a lazy list of tokens from strict 'Text'.
321-- | Parse a lazy list of tokens from strict 'Text'.
269parseTokens :: Text -> [Token]
322parseTokens :: Text -> [Token]
270parseTokens = unfoldr f
323parseTokens = unfoldr f