git.iko.soy/typeable/html-parse
on ff88508 help sign in
typeable/html-parse/Text/HTML/Parser.hs
325 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 <|> tryStartTag
95 <|> other
96 where
97 tryStartTag = do
98 c <- peekChar'
99 guard $ isAsciiUpper c || isAsciiLower c
100 tagName
102 other = do
103 return $ ContentChar '<'
105-- | /§8.2.4.9/: End tag open state
106-- TODO: This isn't right
107endTagOpen :: Parser Token
108endTagOpen = do
109 name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
110 char '>'
111 return $ TagClose name
113-- | /§8.2.4.10/: Tag name state
114--
115-- deviation: no lower-casing
116tagName :: Parser Token
117tagName = do
118 tag <- takeWhile $ notInClass "\x09\x0a\x0c />"
119 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
120 <|> (char '/' >> selfClosingStartTag tag [])
121 <|> (char '>' >> return (TagOpen tag []))
123-- | /§8.2.4.43/: Self-closing start tag state
124selfClosingStartTag :: TagName -> [Attr] -> Parser Token
125selfClosingStartTag tag attrs = do
126 (char '>' >> return (TagOpen tag attrs))
127 <|> beforeAttrName tag attrs
129-- | /§8.2.4.34/: Before attribute name state
130--
131-- deviation: no lower-casing
132beforeAttrName :: TagName -> [Attr] -> Parser Token
133beforeAttrName tag attrs = do
134 skipWhile $ inClass "\x09\x0a\x0c "
135 id $ (char '/' >> selfClosingStartTag tag attrs)
136 <|> (char '>' >> return (TagOpen tag attrs))
137 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
138 <|> attrName tag attrs
140-- | /§8.2.4.35/: Attribute name state
141attrName :: TagName -> [Attr] -> Parser Token
142attrName tag attrs = do
143 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
144 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
145 <|> (char '/' >> selfClosingStartTag tag attrs)
146 <|> (char '=' >> beforeAttrValue tag attrs name)
147 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
148 -- <|> -- TODO: NULL
150-- | /§8.2.4.36/: After attribute name state
151afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
152afterAttrName tag attrs name = do
153 skipWhile $ inClass "\x09\x0a\x0c "
154 id $ (char '/' >> selfClosingStartTag tag attrs)
155 <|> (char '=' >> beforeAttrValue tag attrs name)
156 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
157 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
159-- | /§8.2.4.37/: Before attribute value state
160beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
161beforeAttrValue tag attrs name = do
162 skipWhile $ inClass "\x09\x0a\x0c "
163 id $ (char '"' >> attrValueDQuoted tag attrs name)
164 <|> (char '\'' >> attrValueSQuoted tag attrs name)
165 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
166 <|> attrValueUnquoted tag attrs name
168-- | /§8.2.4.38/: Attribute value (double-quoted) state
169attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
170attrValueDQuoted tag attrs name = do
171 value <- takeWhile (/= '"')
172 char '"'
173 afterAttrValueQuoted tag attrs name value
175-- | /§8.2.4.39/: Attribute value (single-quoted) state
176attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
177attrValueSQuoted tag attrs name = do
178 value <- takeWhile (/= '\'')
179 char '\''
180 afterAttrValueQuoted tag attrs name value
182-- | /§8.2.4.40/: Attribute value (unquoted) state
183attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
184attrValueUnquoted tag attrs name = do
185 value <- takeTill (inClass "\x09\x0a\x0c >")
186 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
187 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
189-- | /§8.2.4.42/: After attribute value (quoted) state
190afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
191afterAttrValueQuoted tag attrs name value =
192 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
193 <|> (char '/' >> selfClosingStartTag tag attrs')
194 <|> (char '>' >> return (TagOpen tag attrs'))
195 where attrs' = Attr name value : attrs
197-- | /§8.2.4.45/: Markup declaration open state
198markupDeclOpen :: Parser Token
199markupDeclOpen =
200 try comment
201 <|> try docType
202 -- TODO: Fix the rest
203 where
204 comment = string "--" >> commentStart
205 docType = do
206 -- switching this to asciiCI slowed things down by a factor of two
207 s <- take 7
208 guard $ T.toLower s == "doctype"
209 doctype
211-- | /§8.2.4.46/: Comment start state
212commentStart :: Parser Token
213commentStart = do
214 (char '-' >> commentStartDash)
215 <|> (char '>' >> return (Comment mempty))
216 <|> comment mempty
218-- | /§8.2.4.47/: Comment start dash state
219commentStartDash :: Parser Token
220commentStartDash =
221 (char '-' >> commentEnd mempty)
222 <|> (char '>' >> return (Comment mempty))
223 <|> (do c <- anyChar
224 comment (B.singleton '-' <> B.singleton c) )
226-- | /§8.2.4.48/: Comment state
227comment :: Builder -> Parser Token
228comment content0 = do
229 content <- B.fromText <$> takeWhile (notInClass "-")
230 id $ (char '-' >> commentEndDash (content0 <> content))
231 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
233-- | /§8.2.4.49/: Comment end dash state
234commentEndDash :: Builder -> Parser Token
235commentEndDash content = do
236 (char '-' >> commentEnd content)
237 <|> (char '\x00' >> comment (content <> "-\xfffd"))
238 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
240-- | /§8.2.4.50/: Comment end state
241commentEnd :: Builder -> Parser Token
242commentEnd content = do
243 (char '>' >> return (Comment content))
244 <|> (char '\x00' >> comment (content <> "-\xfffd"))
245 -- <|> () TODO: other cases
246 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
248-- | /§8.2.4.52/: DOCTYPE state
249-- FIXME
250doctype :: Parser Token
251doctype = do
252 content <- takeTill (=='>')
253 char '>'
254 return $ Doctype content
256-- | /§8.2.4.44/: Bogus comment state
257bogusComment :: Parser Token
258bogusComment = fail "Bogus comment"
260-- | Parse a lazy list of tokens from strict 'Text'.
261parseTokens :: Text -> [Token]
262parseTokens = unfoldr f
263 where
264 f :: Text -> Maybe (Token, Text)
265 f t
266 | T.null t = Nothing
267 | otherwise =
268 case parse token t of
269 Done rest tok -> Just (tok, rest)
270 Partial cont ->
271 case cont mempty of
272 Done rest tok -> Just (tok, rest)
273 _ -> Nothing
274 _ -> Nothing
276-- | Parse a lazy list of tokens from lazy 'TL.Text'.
277parseTokensLazy :: TL.Text -> [Token]
278parseTokensLazy = unfoldr f
279 where
280 f :: TL.Text -> Maybe (Token, TL.Text)
281 f t
282 | TL.null t = Nothing
283 | otherwise =
284 case AL.parse token t of
285 AL.Done rest tok -> Just (tok, rest)
286 _ -> Nothing
288-- | See 'renderToken'.
289renderTokens :: [Token] -> TL.Text
290renderTokens = mconcat . fmap renderToken
292-- | (Somewhat) canonical string representation of 'Token'.
293renderToken :: Token -> TL.Text
294renderToken = TL.fromStrict . mconcat . \case
295 (TagOpen n []) -> ["<", n, ">"]
296 (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]
297 (TagClose n) -> ["</", n, ">"]
298 (ContentChar c) -> [T.singleton c]
299 (ContentText t) -> [t]
300 (Comment builder) -> ["<!--", TL.toStrict $ B.toLazyText builder, "-->"]
301 (Doctype t) -> ["<!DOCTYPE", t, ">"]
303-- | See 'renderAttr'.
304renderAttrs :: [Attr] -> Text
305renderAttrs = T.unwords . fmap renderAttr . reverse
307-- | Does not escape quotation in attribute values!
308renderAttr :: Attr -> Text
309renderAttr (Attr k v) = mconcat [k, "=\"", v, "\""]
311-- | Meld neighoring 'ContentChar' and 'ContentText' constructors together and drops empty text
312-- elements.
313canonicalizeTokens :: [Token] -> [Token]
314canonicalizeTokens = filter (/= ContentText "") . meldTextTokens
316meldTextTokens :: [Token] -> [Token]
317meldTextTokens = concatTexts . fmap charToText
318 where
319 charToText (ContentChar c) = ContentText (T.singleton c)
320 charToText t = t
322 concatTexts = \case
323 (ContentText t : ContentText t' : ts) -> concatTexts $ ContentText (t <> t') : ts
324 (t : ts) -> t : concatTexts ts
325 [] -> []