git.iko.soy/typeable/html-parse
on ff8bcf5 help sign in
typeable/html-parse/Text/HTML/Parser.hs
387 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-- | /§8.2.4.8/: Tag name state: the open case
113--
114-- deviation: no lower-casing, don't handle NULL characters
115tagNameOpen :: Parser Token
116tagNameOpen = do
117 tag <- tagName'
118 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
119 <|> (char '/' >> selfClosingStartTag tag [])
120 <|> (char '>' >> return (TagOpen tag []))
122-- | /§8.2.4.10/: Tag name state: close case
123tagNameClose :: Parser Token
124tagNameClose = do
125 tag <- tagName'
126 char '>' >> return (TagClose tag)
128-- | /§8.2.4.10/: Tag name state: common code
129--
130-- deviation: no lower-casing, don't handle NULL characters
131tagName' :: Parser Text
132tagName' = do
133 c <- peekChar'
134 guard $ isAsciiUpper c || isAsciiLower c
135 takeWhile $ notInClass "\x09\x0a\x0c /<>"
137-- | /§8.2.4.40/: Self-closing start tag state
138selfClosingStartTag :: TagName -> [Attr] -> Parser Token
139selfClosingStartTag tag attrs = do
140 (char '>' >> return (TagSelfClose tag attrs))
141 <|> (endOfInput >> return endOfFileToken)
142 <|> beforeAttrName tag attrs
144-- | /§8.2.4.32/: Before attribute name state
145--
146-- deviation: no lower-casing
147beforeAttrName :: TagName -> [Attr] -> Parser Token
148beforeAttrName tag attrs = do
149 skipWhile $ inClass "\x09\x0a\x0c "
150 id $ (char '/' >> selfClosingStartTag tag attrs)
151 <|> (char '>' >> return (TagOpen tag attrs))
152 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
153 <|> attrName tag attrs
155-- | /§8.2.4.33/: Attribute name state
156attrName :: TagName -> [Attr] -> Parser Token
157attrName tag attrs = do
158 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>"
159 id $ (endOfInput >> afterAttrName tag attrs name)
160 <|> (char '=' >> beforeAttrValue tag attrs name)
161 <|> try (do mc <- peekChar
162 case mc of
163 Just c | inClass "\x09\x0a\x0c />" c -> afterAttrName tag attrs name
164 _ -> empty)
165 -- <|> -- TODO: NULL
167-- | /§8.2.4.34/: After attribute name state
168afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
169afterAttrName tag attrs name = do
170 skipWhile $ inClass "\x09\x0a\x0c "
171 id $ (char '/' >> selfClosingStartTag tag attrs)
172 <|> (char '=' >> beforeAttrValue tag attrs name)
173 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
174 <|> (endOfInput >> return endOfFileToken)
175 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
177-- | /§8.2.4.35/: Before attribute value state
178beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
179beforeAttrValue tag attrs name = do
180 skipWhile $ inClass "\x09\x0a\x0c "
181 id $ (char '"' >> attrValueDQuoted tag attrs name)
182 <|> (char '\'' >> attrValueSQuoted tag attrs name)
183 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
184 <|> attrValueUnquoted tag attrs name
186-- | /§8.2.4.36/: Attribute value (double-quoted) state
187attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
188attrValueDQuoted tag attrs name = do
189 value <- takeWhile (/= '"')
190 _ <- char '"'
191 afterAttrValueQuoted tag attrs name value
193-- | /§8.2.4.37/: Attribute value (single-quoted) state
194attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
195attrValueSQuoted tag attrs name = do
196 value <- takeWhile (/= '\'')
197 _ <- char '\''
198 afterAttrValueQuoted tag attrs name value
200-- | /§8.2.4.38/: Attribute value (unquoted) state
201attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
202attrValueUnquoted tag attrs name = do
203 value <- takeTill (inClass "\x09\x0a\x0c >")
204 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
205 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
206 <|> (endOfInput >> return endOfFileToken)
208-- | /§8.2.4.39/: After attribute value (quoted) state
209afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
210afterAttrValueQuoted tag attrs name value =
211 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
212 <|> (char '/' >> selfClosingStartTag tag attrs')
213 <|> (char '>' >> return (TagOpen tag attrs'))
214 <|> (endOfInput >> return endOfFileToken)
215 where attrs' = Attr name value : attrs
217-- | /§8.2.4.41/: Bogus comment state
218bogusComment :: Builder -> Parser Token
219bogusComment 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))
225-- | /§8.2.4.42/: Markup declaration open state
226markupDeclOpen :: Parser Token
227markupDeclOpen =
228 try comment_
229 <|> try docType
230 <|> bogusComment mempty
231 where
232 comment_ = string "--" >> commentStart
233 docType = do
234 -- switching this to asciiCI slowed things down by a factor of two
235 s <- take 7
236 guard $ T.toLower s == "doctype"
237 doctype
239-- | /§8.2.4.43/: Comment start state
240commentStart :: Parser Token
241commentStart = do
242 (char '-' >> commentStartDash)
243 <|> (char '>' >> return (Comment mempty))
244 <|> comment mempty
246-- | /§8.2.4.44/: Comment start dash state
247commentStartDash :: Parser Token
248commentStartDash =
249 (char '-' >> commentEnd mempty)
250 <|> (char '>' >> return (Comment mempty))
251 <|> (endOfInput >> return (Comment mempty))
252 <|> (comment (B.singleton '-'))
254-- | /§8.2.4.45/: Comment state
255comment :: Builder -> Parser Token
256comment content0 = do
257 content <- B.fromText <$> takeWhile (notInClass "-\x00<")
258 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))
259 <|> (char '-' >> commentEndDash (content0 <> content))
260 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
261 <|> (endOfInput >> return (Comment $ content0 <> content))
263-- | /§8.2.46/: Comment less-than sign state
264commentLessThan :: Builder -> Parser Token
265commentLessThan content =
266 (char '!' >> commentLessThanBang (content <> "!"))
267 <|> (char '<' >> commentLessThan (content <> "<"))
268 <|> comment content
270-- | /§8.2.47/: Comment less-than sign bang state
271commentLessThanBang :: Builder -> Parser Token
272commentLessThanBang content =
273 (char '-' >> commentLessThanBangDash content)
274 <|> comment content
276-- | /§8.2.48/: Comment less-than sign bang dash state
277commentLessThanBangDash :: Builder -> Parser Token
278commentLessThanBangDash content =
279 (char '-' >> commentLessThanBangDashDash content)
280 <|> commentEndDash content
282-- | /§8.2.49/: Comment less-than sign bang dash dash state
283commentLessThanBangDashDash :: Builder -> Parser Token
284commentLessThanBangDashDash content =
285 (char '>' >> comment content)
286 <|> (endOfInput >> comment content)
287 <|> commentEnd content
289-- | /§8.2.4.50/: Comment end dash state
290commentEndDash :: Builder -> Parser Token
291commentEndDash content = do
292 (char '-' >> commentEnd content)
293 <|> (endOfInput >> return (Comment content))
294 <|> (comment (content <> "-"))
296-- | /§8.2.4.51/: Comment end state
297commentEnd :: Builder -> Parser Token
298commentEnd content = do
299 (char '>' >> return (Comment content))
300 <|> (char '!' >> commentEndBang content)
301 <|> (char '-' >> commentEnd (content <> "-"))
302 <|> (endOfInput >> return (Comment content))
303 <|> (comment (content <> "--"))
305-- | /§8.2.4.52/: Comment end bang state
306commentEndBang :: Builder -> Parser Token
307commentEndBang content = do
308 (char '-' >> commentEndDash (content <> "--!"))
309 <|> (char '>' >> return (Comment content))
310 <|> (endOfInput >> return (Comment content))
311 <|> (comment (content <> "--!"))
313-- | /§8.2.4.53/: DOCTYPE state
314-- FIXME
315doctype :: Parser Token
316doctype = do
317 content <- takeTill (=='>')
318 _ <- char '>'
319 return $ Doctype content
321-- | Parse a lazy list of tokens from strict 'Text'.
322parseTokens :: Text -> [Token]
323parseTokens = unfoldr f
324 where
325 f :: Text -> Maybe (Token, Text)
326 f t
327 | T.null t = Nothing
328 | otherwise =
329 case parse token t of
330 Done rest tok -> Just (tok, rest)
331 Partial cont ->
332 case cont mempty of
333 Done rest tok -> Just (tok, rest)
334 _ -> Nothing
335 _ -> Nothing
337-- | Parse a lazy list of tokens from lazy 'TL.Text'.
338parseTokensLazy :: TL.Text -> [Token]
339parseTokensLazy = unfoldr f
340 where
341 f :: TL.Text -> Maybe (Token, TL.Text)
342 f t
343 | TL.null t = Nothing
344 | otherwise =
345 case AL.parse token t of
346 AL.Done rest tok -> Just (tok, rest)
347 _ -> Nothing
349-- | See 'renderToken'.
350renderTokens :: [Token] -> TL.Text
351renderTokens = mconcat . fmap renderToken
353-- | (Somewhat) canonical string representation of 'Token'.
354renderToken :: Token -> TL.Text
355renderToken = TL.fromStrict . mconcat . \case
356 (TagOpen n []) -> ["<", n, ">"]
357 (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]
358 (TagSelfClose n attrs) -> ["<", n, " ", renderAttrs attrs, " />"]
359 (TagClose n) -> ["</", n, ">"]
360 (ContentChar c) -> [T.singleton c]
361 (ContentText t) -> [t]
362 (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]
363 (Doctype t) -> ["<!DOCTYPE", t, ">"]
365-- | See 'renderAttr'.
366renderAttrs :: [Attr] -> Text
367renderAttrs = T.unwords . fmap renderAttr . reverse
369-- | Does not escape quotation in attribute values!
370renderAttr :: Attr -> Text
371renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]
373-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text
374-- elements.
375canonicalizeTokens :: [Token] -> [Token]
376canonicalizeTokens = filter (/= ContentText "") . meldTextTokens
378meldTextTokens :: [Token] -> [Token]
379meldTextTokens = concatTexts . fmap charToText
380 where
381 charToText (ContentChar c) = ContentText (T.singleton c)
382 charToText t = t
384 concatTexts = \case
385 (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts
386 (t : ts) -> t : concatTexts ts
387 [] -> []