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