git.iko.soy/typeable/html-parse
on a934786 help sign in
typeable/html-parse/Text/HTML/Parser.hs
331 lines 11 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-- | A tag name (e.g. @body@)
44type TagName = Text
46-- | An attribute name (e.g. @href@)
47type AttrName = Text
49-- | The value of an attribute
50type AttrValue = Text
52-- | An HTML token
53data Token
54 -- | An opening tag. Attribute ordering is arbitrary.
55 = TagOpen !TagName [Attr]
56 -- | A closing tag.
57 | TagClose !TagName
58 -- | The content between tags.
59 | ContentText !Text
60 -- | A single character of content
61 | ContentChar !Char
62 -- | Contents of a comment.
63 | Comment !Builder
64 -- | Doctype
65 | Doctype !Text
66 deriving (Show, Ord, Eq, Generic)
68-- | An attribute of a tag
69data Attr = Attr !AttrName !AttrValue
70 deriving (Show, Eq, Ord)
72instance NFData Token where
73 rnf (Comment b) = rnf $ B.toLazyText b
74 rnf _ = ()
76-- | Parse a single 'Token'.
77token :: Parser Token
78token = dataState -- Start in the data state.
80-- | /§8.2.4.1/: Data state
81dataState :: Parser Token
82dataState = do
83 content <- takeWhile (/= '<')
84 if not $ T.null content
85 then return $ ContentText content
86 else char '<' >> tagOpen
88-- | /§8.2.4.3/: Tag open state
89tagOpen :: Parser Token
90tagOpen =
91 (char '!' >> markupDeclOpen)
92 <|> (char '/' >> endTagOpen)
93 <|> (char '?' >> bogusComment)
94 <|> tagNameOpen
95 <|> other
96 where
97 other = do
98 return $ ContentChar '<'
100-- | /§8.2.4.9/: End tag open state
101endTagOpen :: Parser Token
102endTagOpen = tagNameClose
104-- | /§8.2.4.10/: Tag name state: the open case
105--
106-- deviation: no lower-casing
107tagNameOpen :: Parser Token
108tagNameOpen = do
109 tag <- tagName'
110 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
111 <|> (char '/' >> selfClosingStartTag tag [])
112 <|> (char '>' >> return (TagOpen tag []))
114-- | /§8.2.4.10/: Tag name state: close case
115tagNameClose :: Parser Token
116tagNameClose = do
117 tag <- tagName'
118 char '>' >> return (TagClose tag)
120-- | /§8.2.4.10/: Tag name state: common code
121--
122-- deviation: no lower-casing
123tagName' :: Parser Text
124tagName' = do
125 c <- peekChar'
126 guard $ isAsciiUpper c || isAsciiLower c
127 takeWhile $ notInClass "\x09\x0a\x0c /<>"
129-- | /§8.2.4.43/: Self-closing start tag state
130selfClosingStartTag :: TagName -> [Attr] -> Parser Token
131selfClosingStartTag tag attrs = do
132 (char '>' >> return (TagOpen tag attrs))
133 <|> beforeAttrName tag attrs
135-- | /§8.2.4.34/: Before attribute name state
136--
137-- deviation: no lower-casing
138beforeAttrName :: TagName -> [Attr] -> Parser Token
139beforeAttrName tag attrs = do
140 skipWhile $ inClass "\x09\x0a\x0c "
141 id $ (char '/' >> selfClosingStartTag tag attrs)
142 <|> (char '>' >> return (TagOpen tag attrs))
143 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
144 <|> attrName tag attrs
146-- | /§8.2.4.35/: Attribute name state
147attrName :: TagName -> [Attr] -> Parser Token
148attrName tag attrs = do
149 name <- takeWhile $ notInClass "\x09\x0a\x0c /=<>\x00"
150 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
151 <|> (char '/' >> selfClosingStartTag tag attrs)
152 <|> (char '=' >> beforeAttrValue tag attrs name)
153 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
154 -- <|> -- TODO: NULL
156-- | /§8.2.4.36/: After attribute name state
157afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
158afterAttrName tag attrs name = do
159 skipWhile $ inClass "\x09\x0a\x0c "
160 id $ (char '/' >> selfClosingStartTag tag attrs)
161 <|> (char '=' >> beforeAttrValue tag attrs name)
162 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
163 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
165-- | /§8.2.4.37/: Before attribute value state
166beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
167beforeAttrValue tag attrs name = do
168 skipWhile $ inClass "\x09\x0a\x0c "
169 id $ (char '"' >> attrValueDQuoted tag attrs name)
170 <|> (char '\'' >> attrValueSQuoted tag attrs name)
171 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
172 <|> attrValueUnquoted tag attrs name
174-- | /§8.2.4.38/: Attribute value (double-quoted) state
175attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
176attrValueDQuoted tag attrs name = do
177 value <- takeWhile (/= '"')
178 char '"'
179 afterAttrValueQuoted tag attrs name value
181-- | /§8.2.4.39/: Attribute value (single-quoted) state
182attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
183attrValueSQuoted tag attrs name = do
184 value <- takeWhile (/= '\'')
185 char '\''
186 afterAttrValueQuoted tag attrs name value
188-- | /§8.2.4.40/: Attribute value (unquoted) state
189attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
190attrValueUnquoted tag attrs name = do
191 value <- takeTill (inClass "\x09\x0a\x0c >")
192 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
193 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
195-- | /§8.2.4.42/: After attribute value (quoted) state
196afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
197afterAttrValueQuoted tag attrs name value =
198 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
199 <|> (char '/' >> selfClosingStartTag tag attrs')
200 <|> (char '>' >> return (TagOpen tag attrs'))
201 where attrs' = Attr name value : attrs
203-- | /§8.2.4.45/: Markup declaration open state
204markupDeclOpen :: Parser Token
205markupDeclOpen =
206 try comment
207 <|> try docType
208 -- TODO: Fix the rest
209 where
210 comment = string "--" >> commentStart
211 docType = do
212 -- switching this to asciiCI slowed things down by a factor of two
213 s <- take 7
214 guard $ T.toLower s == "doctype"
215 doctype
217-- | /§8.2.4.46/: Comment start state
218commentStart :: Parser Token
219commentStart = do
220 (char '-' >> commentStartDash)
221 <|> (char '>' >> return (Comment mempty))
222 <|> comment mempty
224-- | /§8.2.4.47/: Comment start dash state
225commentStartDash :: Parser Token
226commentStartDash =
227 (char '-' >> commentEnd mempty)
228 <|> (char '>' >> return (Comment mempty))
229 <|> (do c <- anyChar
230 comment (B.singleton '-' <> B.singleton c) )
232-- | /§8.2.4.48/: Comment state
233comment :: Builder -> Parser Token
234comment content0 = do
235 content <- B.fromText <$> takeWhile (notInClass "-")
236 id $ (char '-' >> commentEndDash (content0 <> content))
237 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
239-- | /§8.2.4.49/: Comment end dash state
240commentEndDash :: Builder -> Parser Token
241commentEndDash content = do
242 (char '-' >> commentEnd content)
243 <|> (char '\x00' >> comment (content <> "-\xfffd"))
244 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
246-- | /§8.2.4.50/: Comment end state
247commentEnd :: Builder -> Parser Token
248commentEnd content = do
249 (char '>' >> return (Comment content))
250 <|> (char '\x00' >> comment (content <> "-\xfffd"))
251 -- <|> () TODO: other cases
252 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
254-- | /§8.2.4.52/: DOCTYPE state
255-- FIXME
256doctype :: Parser Token
257doctype = do
258 content <- takeTill (=='>')
259 char '>'
260 return $ Doctype content
262-- | /§8.2.4.44/: Bogus comment state
263bogusComment :: Parser Token
264bogusComment = fail "Bogus comment"
266-- | Parse a lazy list of tokens from strict 'Text'.
267parseTokens :: Text -> [Token]
268parseTokens = unfoldr f
269 where
270 f :: Text -> Maybe (Token, Text)
271 f t
272 | T.null t = Nothing
273 | otherwise =
274 case parse token t of
275 Done rest tok -> Just (tok, rest)
276 Partial cont ->
277 case cont mempty of
278 Done rest tok -> Just (tok, rest)
279 _ -> Nothing
280 _ -> Nothing
282-- | Parse a lazy list of tokens from lazy 'TL.Text'.
283parseTokensLazy :: TL.Text -> [Token]
284parseTokensLazy = unfoldr f
285 where
286 f :: TL.Text -> Maybe (Token, TL.Text)
287 f t
288 | TL.null t = Nothing
289 | otherwise =
290 case AL.parse token t of
291 AL.Done rest tok -> Just (tok, rest)
292 _ -> Nothing
294-- | See 'renderToken'.
295renderTokens :: [Token] -> TL.Text
296renderTokens = mconcat . fmap renderToken
298-- | (Somewhat) canonical string representation of 'Token'.
299renderToken :: Token -> TL.Text
300renderToken = TL.fromStrict . mconcat . \case
301 (TagOpen n []) -> ["<", n, ">"]
302 (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]
303 (TagClose n) -> ["</", n, ">"]
304 (ContentChar c) -> [T.singleton c]
305 (ContentText t) -> [t]
306 (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]
307 (Doctype t) -> ["<!DOCTYPE", t, ">"]
309-- | See 'renderAttr'.
310renderAttrs :: [Attr] -> Text
311renderAttrs = T.unwords . fmap renderAttr . reverse
313-- | Does not escape quotation in attribute values!
314renderAttr :: Attr -> Text
315renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]
317-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text
318-- elements.
319canonicalizeTokens :: [Token] -> [Token]
320canonicalizeTokens = filter (/= ContentText "") . meldTextTokens
322meldTextTokens :: [Token] -> [Token]
323meldTextTokens = concatTexts . fmap charToText
324 where
325 charToText (ContentChar c) = ContentText (T.singleton c)
326 charToText t = t
328 concatTexts = \case
329 (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts
330 (t : ts) -> t : concatTexts ts
331 [] -> []