git.iko.soy/typeable/html-parse
on 5ae61d7 help sign in
typeable/html-parse/src/Text/HTML/Parser.hs
429 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 ' ' = True
143isWhitespace _ = False
145orC :: (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
146orC f g c = f c || g c
147{-# INLINE orC #-}
149isC :: Char -> Char -> Bool
150isC = (==)
151{-# INLINE isC #-}
153-- | /§8.2.4.8/: Tag name state: the open case
154--
155-- deviation: no lower-casing, don't handle NULL characters
156tagNameOpen :: Parser Token
157tagNameOpen = do
158 tag <- tagName'
159 id $ (satisfy isWhitespace >> beforeAttrName tag [])
160 <|> (char '/' >> selfClosingStartTag tag [])
161 <|> (char '>' >> return (TagOpen tag []))
163-- | /§8.2.4.10/: Tag name state: close case
164tagNameClose :: Parser Token
165tagNameClose = do
166 tag <- tagName'
167 char '>' >> return (TagClose tag)
169-- | /§8.2.4.10/: Tag name state: common code
170--
171-- deviation: no lower-casing, don't handle NULL characters
172tagName' :: Parser Text
173tagName' = do
174 c <- peekChar'
175 guard $ isAsciiUpper c || isAsciiLower c
176 takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '<' `orC` isC '>')
178-- | /§8.2.4.40/: Self-closing start tag state
179selfClosingStartTag :: TagName -> [Attr] -> Parser Token
180selfClosingStartTag tag attrs = do
181 (char '>' >> return (TagSelfClose tag attrs))
182 <|> (endOfInput >> return endOfFileToken)
183 <|> beforeAttrName tag attrs
185-- | /§8.2.4.32/: Before attribute name state
186--
187-- deviation: no lower-casing
188beforeAttrName :: TagName -> [Attr] -> Parser Token
189beforeAttrName tag attrs = do
190 skipWhile isWhitespace
191 id $ (char '/' >> selfClosingStartTag tag attrs)
192 <|> (char '>' >> return (TagOpen tag attrs))
193 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
194 <|> attrName tag attrs
196-- | /§8.2.4.33/: Attribute name state
197attrName :: TagName -> [Attr] -> Parser Token
198attrName tag attrs = do
199 name <- takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '=' `orC` isC '>')
200 id $ (endOfInput >> afterAttrName tag attrs name)
201 <|> (char '=' >> beforeAttrValue tag attrs name)
202 <|> try (do mc <- peekChar
203 case mc of
204 Just c | notNameChar c -> afterAttrName tag attrs name
205 _ -> empty)
206 -- <|> -- TODO: NULL
207 where notNameChar = isWhitespace `orC` isC '/' `orC` isC '>'
209-- | /§8.2.4.34/: After attribute name state
210afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
211afterAttrName tag attrs name = do
212 skipWhile isWhitespace
213 id $ (char '/' >> selfClosingStartTag tag attrs)
214 <|> (char '=' >> beforeAttrValue tag attrs name)
215 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
216 <|> (endOfInput >> return endOfFileToken)
217 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
219-- | /§8.2.4.35/: Before attribute value state
220beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
221beforeAttrValue tag attrs name = do
222 skipWhile isWhitespace
223 id $ (char '"' >> attrValueDQuoted tag attrs name)
224 <|> (char '\'' >> attrValueSQuoted tag attrs name)
225 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
226 <|> attrValueUnquoted tag attrs name
228-- | /§8.2.4.36/: Attribute value (double-quoted) state
229attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
230attrValueDQuoted tag attrs name = do
231 value <- takeWhile (/= '"')
232 _ <- char '"'
233 afterAttrValueQuoted tag attrs name value
235-- | /§8.2.4.37/: Attribute value (single-quoted) state
236attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
237attrValueSQuoted tag attrs name = do
238 value <- takeWhile (/= '\'')
239 _ <- char '\''
240 afterAttrValueQuoted tag attrs name value
242-- | /§8.2.4.38/: Attribute value (unquoted) state
243attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
244attrValueUnquoted tag attrs name = do
245 value <- takeTill $ isWhitespace `orC` isC '>'
246 id $ (satisfy isWhitespace >> beforeAttrName tag attrs) -- unsure: don't emit?
247 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
248 <|> (endOfInput >> return endOfFileToken)
250-- | /§8.2.4.39/: After attribute value (quoted) state
251afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
252afterAttrValueQuoted tag attrs name value =
253 (satisfy isWhitespace >> beforeAttrName tag attrs')
254 <|> (char '/' >> selfClosingStartTag tag attrs')
255 <|> (char '>' >> return (TagOpen tag attrs'))
256 <|> (endOfInput >> return endOfFileToken)
257 where attrs' = Attr name value : attrs
259-- | /§8.2.4.41/: Bogus comment state
260bogusComment :: Builder -> Parser Token
261bogusComment content = do
262 (char '>' >> return (Comment content))
263 <|> (endOfInput >> return (Comment content))
264 <|> (char '\x00' >> bogusComment (content <> "\xfffd"))
265 <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))
267-- | /§8.2.4.42/: Markup declaration open state
268markupDeclOpen :: Parser Token
269markupDeclOpen =
270 try comment_
271 <|> try docType
272 <|> bogusComment mempty
273 where
274 comment_ = char '-' >> char '-' >> commentStart
275 docType = do
276 -- switching this to asciiCI slowed things down by a factor of two
277 s <- take 7
278 guard $ T.toLower s == "doctype"
279 doctype
281-- | /§8.2.4.43/: Comment start state
282commentStart :: Parser Token
283commentStart = do
284 (char '-' >> commentStartDash)
285 <|> (char '>' >> return (Comment mempty))
286 <|> comment mempty
288-- | /§8.2.4.44/: Comment start dash state
289commentStartDash :: Parser Token
290commentStartDash =
291 (char '-' >> commentEnd mempty)
292 <|> (char '>' >> return (Comment mempty))
293 <|> (endOfInput >> return (Comment mempty))
294 <|> (comment (B.singleton '-'))
296-- | /§8.2.4.45/: Comment state
297comment :: Builder -> Parser Token
298comment content0 = do
299 content <- B.fromText <$> takeWhile (not . (isC '-' `orC` isC '\x00' `orC` isC '<'))
300 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
301 <|> (char '-' >> commentEndDash (content0 <> content))
302 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
303 <|> (endOfInput >> return (Comment $ content0 <> content))
305-- | /§8.2.46/: Comment less-than sign state
306commentLessThan :: Builder -> Parser Token
307commentLessThan content =
308 (char '!' >> commentLessThanBang (content <> "!"))
309 <|> (char '<' >> commentLessThan (content <> "<"))
310 <|> comment content
312-- | /§8.2.47/: Comment less-than sign bang state
313commentLessThanBang :: Builder -> Parser Token
314commentLessThanBang content =
315 (char '-' >> commentLessThanBangDash content)
316 <|> comment content
318-- | /§8.2.48/: Comment less-than sign bang dash state
319commentLessThanBangDash :: Builder -> Parser Token
320commentLessThanBangDash content =
321 (char '-' >> commentLessThanBangDashDash content)
322 <|> commentEndDash content
324-- | /§8.2.49/: Comment less-than sign bang dash dash state
325commentLessThanBangDashDash :: Builder -> Parser Token
326commentLessThanBangDashDash content =
327 (char '>' >> comment content)
328 <|> (endOfInput >> comment content)
329 <|> commentEnd content
331-- | /§8.2.4.50/: Comment end dash state
332commentEndDash :: Builder -> Parser Token
333commentEndDash content = do
334 (char '-' >> commentEnd content)
335 <|> (endOfInput >> return (Comment content))
336 <|> (comment (content <> "-"))
338-- | /§8.2.4.51/: Comment end state
339commentEnd :: Builder -> Parser Token
340commentEnd content = do
341 (char '>' >> return (Comment content))
342 <|> (char '!' >> commentEndBang content)
343 <|> (char '-' >> commentEnd (content <> "-"))
344 <|> (endOfInput >> return (Comment content))
345 <|> (comment (content <> "--"))
347-- | /§8.2.4.52/: Comment end bang state
348commentEndBang :: Builder -> Parser Token
349commentEndBang content = do
350 (char '-' >> commentEndDash (content <> "--!"))
351 <|> (char '>' >> return (Comment content))
352 <|> (endOfInput >> return (Comment content))
353 <|> (comment (content <> "--!"))
355-- | /§8.2.4.53/: DOCTYPE state
356-- FIXME
357doctype :: Parser Token
358doctype = do
359 content <- takeTill (=='>')
360 _ <- char '>'
361 return $ Doctype content
363-- | Parse a lazy list of tokens from strict 'Text'.
364parseTokens :: Text -> [Token]
365parseTokens = unfoldr f
366 where
367 f :: Text -> Maybe (Token, Text)
368 f t
369 | T.null t = Nothing
370 | otherwise =
371 case parse token t of
372 Done rest tok -> Just (tok, rest)
373 Partial cont ->
374 case cont mempty of
375 Done rest tok -> Just (tok, rest)
376 _ -> Nothing
377 _ -> Nothing
379-- | Parse a lazy list of tokens from lazy 'TL.Text'.
380parseTokensLazy :: TL.Text -> [Token]
381parseTokensLazy = unfoldr f
382 where
383 f :: TL.Text -> Maybe (Token, TL.Text)
384 f t
385 | TL.null t = Nothing
386 | otherwise =
387 case AL.parse token t of
388 AL.Done rest tok -> Just (tok, rest)
389 _ -> Nothing
391-- | See 'renderToken'.
392renderTokens :: [Token] -> TL.Text
393renderTokens = mconcat . fmap renderToken
395-- | (Somewhat) canonical string representation of 'Token'.
396renderToken :: Token -> TL.Text
397renderToken = TL.fromStrict . mconcat . \case
398 (TagOpen n []) -> ["<", n, ">"]
399 (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]
400 (TagSelfClose n attrs) -> ["<", n, " ", renderAttrs attrs, " />"]
401 (TagClose n) -> ["</", n, ">"]
402 (ContentChar c) -> [T.singleton c]
403 (ContentText t) -> [t]
404 (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]
405 (Doctype t) -> ["<!DOCTYPE", t, ">"]
407-- | See 'renderAttr'.
408renderAttrs :: [Attr] -> Text
409renderAttrs = T.unwords . fmap renderAttr . reverse
411-- | Does not escape quotation in attribute values!
412renderAttr :: Attr -> Text
413renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]
415-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text
416-- elements.
417canonicalizeTokens :: [Token] -> [Token]
418canonicalizeTokens = filter (/= ContentText "") . meldTextTokens
420meldTextTokens :: [Token] -> [Token]
421meldTextTokens = concatTexts . fmap charToText
422 where
423 charToText (ContentChar c) = ContentText (T.singleton c)
424 charToText t = t
426 concatTexts = \case
427 (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts
428 (t : ts) -> t : concatTexts ts
429 [] -> []