git.iko.soy/typeable/html-parse
on 4420044 help sign in
typeable/html-parse/Text/HTML/Parser.hs
403 lines 13 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE LambdaCase #-}
5-- | This is a performance-oriented HTML tokenizer aim at web-crawling
6-- applications. It follows the HTML5 parsing specification quite closely,
7-- so it behaves reasonable well on ill-formed documents from the open Web.
8--
9module Text.HTML.Parser
10 ( -- * Parsing
11 parseTokens
12 , parseTokensLazy
13 , token
14 -- * Types
15 , Token(..)
16 , TagName, AttrName, AttrValue
17 , Attr(..)
18 -- * Rendering, text canonicalization
19 , renderTokens
20 , renderToken
21 , renderAttrs
22 , renderAttr
23 , canonicalizeTokens
24 ) where
26import Data.Char hiding (isSpace)
27import Data.List (unfoldr)
28import GHC.Generics
29import Control.Applicative
30import Data.Monoid
31import Control.Monad (guard)
32import Control.DeepSeq
34import Data.Attoparsec.Text
35import qualified Data.Attoparsec.Text.Lazy as AL
36import Data.Text (Text)
37import qualified Data.Text as T
38import qualified Data.Text.Lazy as TL
39import Data.Text.Lazy.Builder (Builder)
40import qualified Data.Text.Lazy.Builder as B
41import Prelude hiding (take, takeWhile)
43-- Section numbers refer to W3C HTML 5.2 specification.
45-- | A tag name (e.g. @body@)
46type TagName = Text
48-- | An attribute name (e.g. @href@)
49type AttrName = Text
51-- | The value of an attribute
52type AttrValue = Text
54-- | An HTML token
55data Token
56 -- | An opening tag. Attribute ordering is arbitrary.
57 = TagOpen !TagName [Attr]
58 -- | A self-closing tag.
59 | TagSelfClose !TagName [Attr]
60 -- | A closing tag.
61 | TagClose !TagName
62 -- | The content between tags.
63 | ContentText !Text
64 -- | A single character of content
65 | ContentChar !Char
66 -- | Contents of a comment.
67 | Comment !Builder
68 -- | Doctype
69 | Doctype !Text
70 deriving (Show, Ord, Eq, Generic)
72-- | This is a bit of a hack
73endOfFileToken :: Token
74endOfFileToken = ContentText ""
76-- | An attribute of a tag
77data Attr = Attr !AttrName !AttrValue
78 deriving (Show, Eq, Ord)
80instance NFData Token where
81 rnf (Comment b) = rnf $ B.toLazyText b
82 rnf _ = ()
84-- | Parse a single 'Token'.
85token :: Parser Token
86token = dataState -- Start in the data state.
88-- | /§8.2.4.1/: Data state
89dataState :: Parser Token
90dataState = do
91 content <- takeWhile (/= '<')
92 if not $ T.null content
93 then return $ ContentText content
94 else char '<' >> tagOpen
96-- | /§8.2.4.6/: Tag open state
97tagOpen :: Parser Token
98tagOpen =
99 (char '!' >> markupDeclOpen)
100 <|> (char '/' >> endTagOpen)
101 <|> (char '?' >> bogusComment mempty)
102 <|> tagNameOpen
103 <|> other
104 where
105 other = do
106 return $ ContentChar '<'
108-- | /§8.2.4.7/: End tag open state
109endTagOpen :: Parser Token
110endTagOpen = tagNameClose
112-- | Equivalent to @inClass "\x09\x0a\x0c "@
113isWhitespace :: Char -> Bool
114isWhitespace '\x09' = True
115isWhitespace '\x0a' = True
116isWhitespace '\x0c' = True
117isWhitespace ' ' = True
118isWhitespace _ = False
120orC :: (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
121orC f g c = f c || g c
122{-# INLINE orC #-}
124isC :: Char -> Char -> Bool
125isC = (==)
126{-# INLINE isC #-}
128-- | /§8.2.4.8/: Tag name state: the open case
129--
130-- deviation: no lower-casing, don't handle NULL characters
131tagNameOpen :: Parser Token
132tagNameOpen = do
133 tag <- tagName'
134 id $ (satisfy isWhitespace >> beforeAttrName tag [])
135 <|> (char '/' >> selfClosingStartTag tag [])
136 <|> (char '>' >> return (TagOpen tag []))
138-- | /§8.2.4.10/: Tag name state: close case
139tagNameClose :: Parser Token
140tagNameClose = do
141 tag <- tagName'
142 char '>' >> return (TagClose tag)
144-- | /§8.2.4.10/: Tag name state: common code
145--
146-- deviation: no lower-casing, don't handle NULL characters
147tagName' :: Parser Text
148tagName' = do
149 c <- peekChar'
150 guard $ isAsciiUpper c || isAsciiLower c
151 takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '<' `orC` isC '>')
153-- | /§8.2.4.40/: Self-closing start tag state
154selfClosingStartTag :: TagName -> [Attr] -> Parser Token
155selfClosingStartTag tag attrs = do
156 (char '>' >> return (TagSelfClose tag attrs))
157 <|> (endOfInput >> return endOfFileToken)
158 <|> beforeAttrName tag attrs
160-- | /§8.2.4.32/: Before attribute name state
161--
162-- deviation: no lower-casing
163beforeAttrName :: TagName -> [Attr] -> Parser Token
164beforeAttrName tag attrs = do
165 skipWhile isWhitespace
166 id $ (char '/' >> selfClosingStartTag tag attrs)
167 <|> (char '>' >> return (TagOpen tag attrs))
168 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
169 <|> attrName tag attrs
171-- | /§8.2.4.33/: Attribute name state
172attrName :: TagName -> [Attr] -> Parser Token
173attrName tag attrs = do
174 name <- takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '=' `orC` isC '>')
175 id $ (endOfInput >> afterAttrName tag attrs name)
176 <|> (char '=' >> beforeAttrValue tag attrs name)
177 <|> try (do mc <- peekChar
178 case mc of
179 Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name
180 _ -> empty)
181 -- <|> -- TODO: NULL
183-- | /§8.2.4.34/: After attribute name state
184afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
185afterAttrName tag attrs name = do
186 skipWhile isWhitespace
187 id $ (char '/' >> selfClosingStartTag tag attrs)
188 <|> (char '=' >> beforeAttrValue tag attrs name)
189 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
190 <|> (endOfInput >> return endOfFileToken)
191 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
193-- | /§8.2.4.35/: Before attribute value state
194beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
195beforeAttrValue tag attrs name = do
196 skipWhile isWhitespace
197 id $ (char '"' >> attrValueDQuoted tag attrs name)
198 <|> (char '\'' >> attrValueSQuoted tag attrs name)
199 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
200 <|> attrValueUnquoted tag attrs name
202-- | /§8.2.4.36/: Attribute value (double-quoted) state
203attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
204attrValueDQuoted tag attrs name = do
205 value <- takeWhile (/= '"')
206 _ <- char '"'
207 afterAttrValueQuoted tag attrs name value
209-- | /§8.2.4.37/: Attribute value (single-quoted) state
210attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
211attrValueSQuoted tag attrs name = do
212 value <- takeWhile (/= '\'')
213 _ <- char '\''
214 afterAttrValueQuoted tag attrs name value
216-- | /§8.2.4.38/: Attribute value (unquoted) state
217attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
218attrValueUnquoted tag attrs name = do
219 value <- takeTill (inClass "\x09\x0a\x0c >")
220 id $ (satisfy isWhitespace >> beforeAttrName tag attrs) -- unsure: don't emit?
221 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
222 <|> (endOfInput >> return endOfFileToken)
224-- | /§8.2.4.39/: After attribute value (quoted) state
225afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
226afterAttrValueQuoted tag attrs name value =
227 (satisfy isWhitespace >> beforeAttrName tag attrs')
228 <|> (char '/' >> selfClosingStartTag tag attrs')
229 <|> (char '>' >> return (TagOpen tag attrs'))
230 <|> (endOfInput >> return endOfFileToken)
231 where attrs' = Attr name value : attrs
233-- | /§8.2.4.41/: Bogus comment state
234bogusComment :: Builder -> Parser Token
235bogusComment content = do
236 (char '>' >> return (Comment content))
237 <|> (endOfInput >> return (Comment content))
238 <|> (char '\x00' >> bogusComment (content <> "\xfffd"))
239 <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))
241-- | /§8.2.4.42/: Markup declaration open state
242markupDeclOpen :: Parser Token
243markupDeclOpen =
244 try comment_
245 <|> try docType
246 <|> bogusComment mempty
247 where
248 comment_ = char '-' >> char '-' >> commentStart
249 docType = do
250 -- switching this to asciiCI slowed things down by a factor of two
251 s <- take 7
252 guard $ T.toLower s == "doctype"
253 doctype
255-- | /§8.2.4.43/: Comment start state
256commentStart :: Parser Token
257commentStart = do
258 (char '-' >> commentStartDash)
259 <|> (char '>' >> return (Comment mempty))
260 <|> comment mempty
262-- | /§8.2.4.44/: Comment start dash state
263commentStartDash :: Parser Token
264commentStartDash =
265 (char '-' >> commentEnd mempty)
266 <|> (char '>' >> return (Comment mempty))
267 <|> (endOfInput >> return (Comment mempty))
268 <|> (comment (B.singleton '-'))
270-- | /§8.2.4.45/: Comment state
271comment :: Builder -> Parser Token
272comment content0 = do
273 content <- B.fromText <$> takeWhile (not . (isC '-' `orC` isC '\x00' `orC` isC '<'))
274 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
275 <|> (char '-' >> commentEndDash (content0 <> content))
276 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
277 <|> (endOfInput >> return (Comment $ content0 <> content))
279-- | /§8.2.46/: Comment less-than sign state
280commentLessThan :: Builder -> Parser Token
281commentLessThan content =
282 (char '!' >> commentLessThanBang (content <> "!"))
283 <|> (char '<' >> commentLessThan (content <> "<"))
284 <|> comment content
286-- | /§8.2.47/: Comment less-than sign bang state
287commentLessThanBang :: Builder -> Parser Token
288commentLessThanBang content =
289 (char '-' >> commentLessThanBangDash content)
290 <|> comment content
292-- | /§8.2.48/: Comment less-than sign bang dash state
293commentLessThanBangDash :: Builder -> Parser Token
294commentLessThanBangDash content =
295 (char '-' >> commentLessThanBangDashDash content)
296 <|> commentEndDash content
298-- | /§8.2.49/: Comment less-than sign bang dash dash state
299commentLessThanBangDashDash :: Builder -> Parser Token
300commentLessThanBangDashDash content =
301 (char '>' >> comment content)
302 <|> (endOfInput >> comment content)
303 <|> commentEnd content
305-- | /§8.2.4.50/: Comment end dash state
306commentEndDash :: Builder -> Parser Token
307commentEndDash content = do
308 (char '-' >> commentEnd content)
309 <|> (endOfInput >> return (Comment content))
310 <|> (comment (content <> "-"))
312-- | /§8.2.4.51/: Comment end state
313commentEnd :: Builder -> Parser Token
314commentEnd content = do
315 (char '>' >> return (Comment content))
316 <|> (char '!' >> commentEndBang content)
317 <|> (char '-' >> commentEnd (content <> "-"))
318 <|> (endOfInput >> return (Comment content))
319 <|> (comment (content <> "--"))
321-- | /§8.2.4.52/: Comment end bang state
322commentEndBang :: Builder -> Parser Token
323commentEndBang content = do
324 (char '-' >> commentEndDash (content <> "--!"))
325 <|> (char '>' >> return (Comment content))
326 <|> (endOfInput >> return (Comment content))
327 <|> (comment (content <> "--!"))
329-- | /§8.2.4.53/: DOCTYPE state
330-- FIXME
331doctype :: Parser Token
332doctype = do
333 content <- takeTill (=='>')
334 _ <- char '>'
335 return $ Doctype content
337-- | Parse a lazy list of tokens from strict 'Text'.
338parseTokens :: Text -> [Token]
339parseTokens = unfoldr f
340 where
341 f :: Text -> Maybe (Token, Text)
342 f t
343 | T.null t = Nothing
344 | otherwise =
345 case parse token t of
346 Done rest tok -> Just (tok, rest)
347 Partial cont ->
348 case cont mempty of
349 Done rest tok -> Just (tok, rest)
350 _ -> Nothing
351 _ -> Nothing
353-- | Parse a lazy list of tokens from lazy 'TL.Text'.
354parseTokensLazy :: TL.Text -> [Token]
355parseTokensLazy = unfoldr f
356 where
357 f :: TL.Text -> Maybe (Token, TL.Text)
358 f t
359 | TL.null t = Nothing
360 | otherwise =
361 case AL.parse token t of
362 AL.Done rest tok -> Just (tok, rest)
363 _ -> Nothing
365-- | See 'renderToken'.
366renderTokens :: [Token] -> TL.Text
367renderTokens = mconcat . fmap renderToken
369-- | (Somewhat) canonical string representation of 'Token'.
370renderToken :: Token -> TL.Text
371renderToken = TL.fromStrict . mconcat . \case
372 (TagOpen n []) -> ["<", n, ">"]
373 (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]
374 (TagSelfClose n attrs) -> ["<", n, " ", renderAttrs attrs, " />"]
375 (TagClose n) -> ["</", n, ">"]
376 (ContentChar c) -> [T.singleton c]
377 (ContentText t) -> [t]
378 (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]
379 (Doctype t) -> ["<!DOCTYPE", t, ">"]
381-- | See 'renderAttr'.
382renderAttrs :: [Attr] -> Text
383renderAttrs = T.unwords . fmap renderAttr . reverse
385-- | Does not escape quotation in attribute values!
386renderAttr :: Attr -> Text
387renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]
389-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text
390-- elements.
391canonicalizeTokens :: [Token] -> [Token]
392canonicalizeTokens = filter (/= ContentText "") . meldTextTokens
394meldTextTokens :: [Token] -> [Token]
395meldTextTokens = concatTexts . fmap charToText
396 where
397 charToText (ContentChar c) = ContentText (T.singleton c)
398 charToText t = t
400 concatTexts = \case
401 (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts
402 (t : ts) -> t : concatTexts ts
403 [] -> []