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