git.iko.soy/typeable/html-parse
on ee02333 help sign in
typeable/html-parse/Text/HTML/Parser.hs
406 lines 13 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)
45-- Section numbers refer to W3C HTML 5.2 specification.
47-- | A tag name (e.g. @body@)
48type TagName = Text
50-- | An attribute name (e.g. @href@)
51type AttrName = Text
53-- | The value of an attribute
54type AttrValue = Text
56-- | An HTML token
57data Token
58 -- | An opening tag. Attribute ordering is arbitrary.
59 = TagOpen !TagName [Attr]
60 -- | A self-closing tag.
61 | TagSelfClose !TagName [Attr]
62 -- | A closing tag.
63 | TagClose !TagName
64 -- | The content between tags.
65 | ContentText !Text
66 -- | A single character of content
67 | ContentChar !Char
68 -- | Contents of a comment.
69 | Comment !Builder
70 -- | Doctype
71 | Doctype !Text
72 deriving (Show, Ord, Eq, Generic)
74-- | This is a bit of a hack
75endOfFileToken :: Token
76endOfFileToken = ContentText ""
78-- | An attribute of a tag
79data Attr = Attr !AttrName !AttrValue
80 deriving (Show, Eq, Ord)
82instance NFData Token where
83 rnf (Comment b) = rnf $ B.toLazyText b
84 rnf _ = ()
86-- | Parse a single 'Token'.
87token :: Parser Token
88token = dataState -- Start in the data state.
90-- | /§8.2.4.1/: Data state
91dataState :: Parser Token
92dataState = do
93 content <- takeWhile (/= '<')
94 if not $ T.null content
95 then return $ ContentText content
96 else char '<' >> tagOpen
98-- | /§8.2.4.6/: Tag open state
99tagOpen :: Parser Token
100tagOpen =
101 (char '!' >> markupDeclOpen)
102 <|> (char '/' >> endTagOpen)
103 <|> (char '?' >> bogusComment mempty)
104 <|> tagNameOpen
105 <|> other
106 where
107 other = do
108 return $ ContentChar '<'
110-- | /§8.2.4.7/: End tag open state
111endTagOpen :: Parser Token
112endTagOpen = tagNameClose
114-- | Equivalent to @inClass "\x09\x0a\x0c "@
115isWhitespace :: Char -> Bool
116isWhitespace '\x09' = True
117isWhitespace '\x0a' = True
118isWhitespace '\x0c' = True
119isWhitespace ' ' = True
120isWhitespace _ = False
122orC :: (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
123orC f g c = f c || g c
124{-# INLINE orC #-}
126isC :: Char -> Char -> Bool
127isC = (==)
128{-# INLINE isC #-}
130-- | /§8.2.4.8/: Tag name state: the open case
131--
132-- deviation: no lower-casing, don't handle NULL characters
133tagNameOpen :: Parser Token
134tagNameOpen = do
135 tag <- tagName'
136 id $ (satisfy isWhitespace >> beforeAttrName tag [])
137 <|> (char '/' >> selfClosingStartTag tag [])
138 <|> (char '>' >> return (TagOpen tag []))
140-- | /§8.2.4.10/: Tag name state: close case
141tagNameClose :: Parser Token
142tagNameClose = do
143 tag <- tagName'
144 char '>' >> return (TagClose tag)
146-- | /§8.2.4.10/: Tag name state: common code
147--
148-- deviation: no lower-casing, don't handle NULL characters
149tagName' :: Parser Text
150tagName' = do
151 c <- peekChar'
152 guard $ isAsciiUpper c || isAsciiLower c
153 takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '<' `orC` isC '>')
155-- | /§8.2.4.40/: Self-closing start tag state
156selfClosingStartTag :: TagName -> [Attr] -> Parser Token
157selfClosingStartTag tag attrs = do
158 (char '>' >> return (TagSelfClose tag attrs))
159 <|> (endOfInput >> return endOfFileToken)
160 <|> beforeAttrName tag attrs
162-- | /§8.2.4.32/: Before attribute name state
163--
164-- deviation: no lower-casing
165beforeAttrName :: TagName -> [Attr] -> Parser Token
166beforeAttrName tag attrs = do
167 skipWhile isWhitespace
168 id $ (char '/' >> selfClosingStartTag tag attrs)
169 <|> (char '>' >> return (TagOpen tag attrs))
170 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
171 <|> attrName tag attrs
173-- | /§8.2.4.33/: Attribute name state
174attrName :: TagName -> [Attr] -> Parser Token
175attrName tag attrs = do
176 name <- takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '=' `orC` isC '>')
177 id $ (endOfInput >> afterAttrName tag attrs name)
178 <|> (char '=' >> beforeAttrValue tag attrs name)
179 <|> try (do mc <- peekChar
180 case mc of
181 Just c | notNameChar c -> afterAttrName tag attrs name
182 _ -> empty)
183 -- <|> -- TODO: NULL
184 where notNameChar = isWhitespace `orC` isC '/' `orC` isC '>'
186-- | /§8.2.4.34/: After attribute name state
187afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
188afterAttrName tag attrs name = do
189 skipWhile isWhitespace
190 id $ (char '/' >> selfClosingStartTag tag attrs)
191 <|> (char '=' >> beforeAttrValue tag attrs name)
192 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
193 <|> (endOfInput >> return endOfFileToken)
194 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
196-- | /§8.2.4.35/: Before attribute value state
197beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
198beforeAttrValue tag attrs name = do
199 skipWhile isWhitespace
200 id $ (char '"' >> attrValueDQuoted tag attrs name)
201 <|> (char '\'' >> attrValueSQuoted tag attrs name)
202 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
203 <|> attrValueUnquoted tag attrs name
205-- | /§8.2.4.36/: Attribute value (double-quoted) state
206attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
207attrValueDQuoted tag attrs name = do
208 value <- takeWhile (/= '"')
209 _ <- char '"'
210 afterAttrValueQuoted tag attrs name value
212-- | /§8.2.4.37/: Attribute value (single-quoted) state
213attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
214attrValueSQuoted tag attrs name = do
215 value <- takeWhile (/= '\'')
216 _ <- char '\''
217 afterAttrValueQuoted tag attrs name value
219-- | /§8.2.4.38/: Attribute value (unquoted) state
220attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
221attrValueUnquoted tag attrs name = do
222 value <- takeTill $ isWhitespace `orC` isC '>'
223 id $ (satisfy isWhitespace >> beforeAttrName tag attrs) -- unsure: don't emit?
224 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
225 <|> (endOfInput >> return endOfFileToken)
227-- | /§8.2.4.39/: After attribute value (quoted) state
228afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
229afterAttrValueQuoted tag attrs name value =
230 (satisfy isWhitespace >> beforeAttrName tag attrs')
231 <|> (char '/' >> selfClosingStartTag tag attrs')
232 <|> (char '>' >> return (TagOpen tag attrs'))
233 <|> (endOfInput >> return endOfFileToken)
234 where attrs' = Attr name value : attrs
236-- | /§8.2.4.41/: Bogus comment state
237bogusComment :: Builder -> Parser Token
238bogusComment content = do
239 (char '>' >> return (Comment content))
240 <|> (endOfInput >> return (Comment content))
241 <|> (char '\x00' >> bogusComment (content <> "\xfffd"))
242 <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))
244-- | /§8.2.4.42/: Markup declaration open state
245markupDeclOpen :: Parser Token
246markupDeclOpen =
247 try comment_
248 <|> try docType
249 <|> bogusComment mempty
250 where
251 comment_ = char '-' >> char '-' >> commentStart
252 docType = do
253 -- switching this to asciiCI slowed things down by a factor of two
254 s <- take 7
255 guard $ T.toLower s == "doctype"
256 doctype
258-- | /§8.2.4.43/: Comment start state
259commentStart :: Parser Token
260commentStart = do
261 (char '-' >> commentStartDash)
262 <|> (char '>' >> return (Comment mempty))
263 <|> comment mempty
265-- | /§8.2.4.44/: Comment start dash state
266commentStartDash :: Parser Token
267commentStartDash =
268 (char '-' >> commentEnd mempty)
269 <|> (char '>' >> return (Comment mempty))
270 <|> (endOfInput >> return (Comment mempty))
271 <|> (comment (B.singleton '-'))
273-- | /§8.2.4.45/: Comment state
274comment :: Builder -> Parser Token
275comment content0 = do
276 content <- B.fromText <$> takeWhile (not . (isC '-' `orC` isC '\x00' `orC` isC '<'))
277 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
278 <|> (char '-' >> commentEndDash (content0 <> content))
279 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
280 <|> (endOfInput >> return (Comment $ content0 <> content))
282-- | /§8.2.46/: Comment less-than sign state
283commentLessThan :: Builder -> Parser Token
284commentLessThan content =
285 (char '!' >> commentLessThanBang (content <> "!"))
286 <|> (char '<' >> commentLessThan (content <> "<"))
287 <|> comment content
289-- | /§8.2.47/: Comment less-than sign bang state
290commentLessThanBang :: Builder -> Parser Token
291commentLessThanBang content =
292 (char '-' >> commentLessThanBangDash content)
293 <|> comment content
295-- | /§8.2.48/: Comment less-than sign bang dash state
296commentLessThanBangDash :: Builder -> Parser Token
297commentLessThanBangDash content =
298 (char '-' >> commentLessThanBangDashDash content)
299 <|> commentEndDash content
301-- | /§8.2.49/: Comment less-than sign bang dash dash state
302commentLessThanBangDashDash :: Builder -> Parser Token
303commentLessThanBangDashDash content =
304 (char '>' >> comment content)
305 <|> (endOfInput >> comment content)
306 <|> commentEnd content
308-- | /§8.2.4.50/: Comment end dash state
309commentEndDash :: Builder -> Parser Token
310commentEndDash content = do
311 (char '-' >> commentEnd content)
312 <|> (endOfInput >> return (Comment content))
313 <|> (comment (content <> "-"))
315-- | /§8.2.4.51/: Comment end state
316commentEnd :: Builder -> Parser Token
317commentEnd content = do
318 (char '>' >> return (Comment content))
319 <|> (char '!' >> commentEndBang content)
320 <|> (char '-' >> commentEnd (content <> "-"))
321 <|> (endOfInput >> return (Comment content))
322 <|> (comment (content <> "--"))
324-- | /§8.2.4.52/: Comment end bang state
325commentEndBang :: Builder -> Parser Token
326commentEndBang content = do
327 (char '-' >> commentEndDash (content <> "--!"))
328 <|> (char '>' >> return (Comment content))
329 <|> (endOfInput >> return (Comment content))
330 <|> (comment (content <> "--!"))
332-- | /§8.2.4.53/: DOCTYPE state
333-- FIXME
334doctype :: Parser Token
335doctype = do
336 content <- takeTill (=='>')
337 _ <- char '>'
338 return $ Doctype content
340-- | Parse a lazy list of tokens from strict 'Text'.
341parseTokens :: Text -> [Token]
342parseTokens = unfoldr f
343 where
344 f :: Text -> Maybe (Token, Text)
345 f t
346 | T.null t = Nothing
347 | otherwise =
348 case parse token t of
349 Done rest tok -> Just (tok, rest)
350 Partial cont ->
351 case cont mempty of
352 Done rest tok -> Just (tok, rest)
353 _ -> Nothing
354 _ -> Nothing
356-- | Parse a lazy list of tokens from lazy 'TL.Text'.
357parseTokensLazy :: TL.Text -> [Token]
358parseTokensLazy = unfoldr f
359 where
360 f :: TL.Text -> Maybe (Token, TL.Text)
361 f t
362 | TL.null t = Nothing
363 | otherwise =
364 case AL.parse token t of
365 AL.Done rest tok -> Just (tok, rest)
366 _ -> Nothing
368-- | See 'renderToken'.
369renderTokens :: [Token] -> TL.Text
370renderTokens = mconcat . fmap renderToken
372-- | (Somewhat) canonical string representation of 'Token'.
373renderToken :: Token -> TL.Text
374renderToken = TL.fromStrict . mconcat . \case
375 (TagOpen n []) -> ["<", n, ">"]
376 (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]
377 (TagSelfClose n attrs) -> ["<", n, " ", renderAttrs attrs, " />"]
378 (TagClose n) -> ["</", n, ">"]
379 (ContentChar c) -> [T.singleton c]
380 (ContentText t) -> [t]
381 (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]
382 (Doctype t) -> ["<!DOCTYPE", t, ">"]
384-- | See 'renderAttr'.
385renderAttrs :: [Attr] -> Text
386renderAttrs = T.unwords . fmap renderAttr . reverse
388-- | Does not escape quotation in attribute values!
389renderAttr :: Attr -> Text
390renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]
392-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text
393-- elements.
394canonicalizeTokens :: [Token] -> [Token]
395canonicalizeTokens = filter (/= ContentText "") . meldTextTokens
397meldTextTokens :: [Token] -> [Token]
398meldTextTokens = concatTexts . fmap charToText
399 where
400 charToText (ContentChar c) = ContentText (T.singleton c)
401 charToText t = t
403 concatTexts = \case
404 (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts
405 (t : ts) -> t : concatTexts ts
406 [] -> []