git.iko.soy/typeable/html-parse
on 080f907 help sign in
typeable/html-parse/Text/HTML/Parser.hs
274 lines 8.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE DeriveGeneric #-}
4-- | This is a performance-oriented HTML tokenizer aim at web-crawling
5-- applications. It follows the HTML5 parsing specification quite closely,
6-- so it behaves reasonable well on ill-formed documents from the open Web.
7--
8module Text.HTML.Parser
9 ( -- * Parsing
10 parseTokens
11 , parseTokensLazy
12 , token
13 -- * Types
14 , Token(..)
15 , TagName, AttrName, AttrValue
16 , Attr(..)
17 ) where
19import Data.Char hiding (isSpace)
20import Data.List (unfoldr)
21import GHC.Generics
22import Control.Applicative
23import Data.Monoid
24import Control.Monad (guard)
25import Control.DeepSeq
27import Data.Attoparsec.Text
28import qualified Data.Attoparsec.Text.Lazy as AL
29import Data.Text (Text)
30import qualified Data.Text as T
31import qualified Data.Text.Lazy as TL
32import Data.Text.Lazy.Builder (Builder)
33import qualified Data.Text.Lazy.Builder as B
34import Prelude hiding (take, takeWhile)
36-- | A tag name (e.g. @body@)
37type TagName = Text
39-- | An attribute name (e.g. @href@)
40type AttrName = Text
42-- | The value of an attribute
43type AttrValue = Text
45-- | An HTML token
46data Token
47 -- | An opening tag. Attribute ordering is arbitrary.
48 = TagOpen !TagName [Attr]
49 -- | A closing tag.
50 | TagClose !TagName
51 -- | The content between tags.
52 | ContentText !Text
53 -- | A single character of content
54 | ContentChar !Char
55 -- | Contents of a comment.
56 | Comment !Builder
57 -- | Doctype
58 | Doctype !Text
59 deriving (Show, Ord, Eq, Generic)
61-- | An attribute of a tag
62data Attr = Attr !AttrName !AttrValue
63 deriving (Show, Eq, Ord)
65instance NFData Token where
66 rnf (Comment b) = rnf $ B.toLazyText b
67 rnf _ = ()
69-- | Parse a single 'Token'.
70token :: Parser Token
71token = dataState -- Start in the data state.
73-- | /§8.2.4.1/: Data state
74dataState :: Parser Token
75dataState = do
76 content <- takeWhile (/= '<')
77 if not $ T.null content
78 then return $ ContentText content
79 else char '<' >> tagOpen
81-- | /§8.2.4.3/: Tag open state
82tagOpen :: Parser Token
83tagOpen =
84 (char '!' >> markupDeclOpen)
85 <|> (char '/' >> endTagOpen)
86 <|> (char '?' >> bogusComment)
87 <|> tryStartTag
88 <|> other
89 where
90 tryStartTag = do
91 c <- peekChar'
92 guard $ isAsciiUpper c || isAsciiLower c
93 tagName
95 other = do
96 return $ ContentChar '<'
98-- | /§8.2.4.9/: End tag open state
99-- TODO: This isn't right
100endTagOpen :: Parser Token
101endTagOpen = do
102 name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
103 char '>'
104 return $ TagClose name
106-- | /§8.2.4.10/: Tag name state
107--
108-- deviation: no lower-casing
109tagName :: Parser Token
110tagName = do
111 tag <- takeWhile $ notInClass "\x09\x0a\x0c />"
112 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
113 <|> (char '/' >> selfClosingStartTag tag [])
114 <|> (char '>' >> return (TagOpen tag []))
116-- | /§8.2.4.43/: Self-closing start tag state
117selfClosingStartTag :: TagName -> [Attr] -> Parser Token
118selfClosingStartTag tag attrs = do
119 (char '>' >> return (TagOpen tag attrs))
120 <|> beforeAttrName tag attrs
122-- | /§8.2.4.34/: Before attribute name state
123--
124-- deviation: no lower-casing
125beforeAttrName :: TagName -> [Attr] -> Parser Token
126beforeAttrName tag attrs = do
127 skipWhile $ inClass "\x09\x0a\x0c "
128 id $ (char '/' >> selfClosingStartTag tag attrs)
129 <|> (char '>' >> return (TagOpen tag attrs))
130 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
131 <|> attrName tag attrs
133-- | /§8.2.4.35/: Attribute name state
134attrName :: TagName -> [Attr] -> Parser Token
135attrName tag attrs = do
136 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
137 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
138 <|> (char '/' >> selfClosingStartTag tag attrs)
139 <|> (char '=' >> beforeAttrValue tag attrs name)
140 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
141 -- <|> -- TODO: NULL
143-- | /§8.2.4.36/: After attribute name state
144afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
145afterAttrName tag attrs name = do
146 skipWhile $ inClass "\x09\x0a\x0c "
147 id $ (char '/' >> selfClosingStartTag tag attrs)
148 <|> (char '=' >> beforeAttrValue tag attrs name)
149 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
150 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
152-- | /§8.2.4.37/: Before attribute value state
153beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
154beforeAttrValue tag attrs name = do
155 skipWhile $ inClass "\x09\x0a\x0c "
156 id $ (char '"' >> attrValueDQuoted tag attrs name)
157 <|> (char '\'' >> attrValueSQuoted tag attrs name)
158 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
159 <|> attrValueUnquoted tag attrs name
161-- | /§8.2.4.38/: Attribute value (double-quoted) state
162attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
163attrValueDQuoted tag attrs name = do
164 value <- takeWhile (/= '"')
165 char '"'
166 afterAttrValueQuoted tag attrs name value
168-- | /§8.2.4.39/: Attribute value (single-quoted) state
169attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
170attrValueSQuoted tag attrs name = do
171 value <- takeWhile (/= '\'')
172 char '\''
173 afterAttrValueQuoted tag attrs name value
175-- | /§8.2.4.40/: Attribute value (unquoted) state
176attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
177attrValueUnquoted tag attrs name = do
178 value <- takeTill (inClass "\x09\x0a\x0c >")
179 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
180 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
182-- | /§8.2.4.42/: After attribute value (quoted) state
183afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
184afterAttrValueQuoted tag attrs name value =
185 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
186 <|> (char '/' >> selfClosingStartTag tag attrs')
187 <|> (char '>' >> return (TagOpen tag attrs'))
188 where attrs' = Attr name value : attrs
190-- | /§8.2.4.45/: Markup declaration open state
191markupDeclOpen :: Parser Token
192markupDeclOpen =
193 try comment
194 <|> try docType
195 -- TODO: Fix the rest
196 where
197 comment = string "--" >> commentStart
198 docType = do
199 -- switching this to asciiCI slowed things down by a factor of two
200 s <- take 7
201 guard $ T.toLower s == "doctype"
202 doctype
204-- | /§8.2.4.46/: Comment start state
205commentStart :: Parser Token
206commentStart = do
207 (char '-' >> commentStartDash)
208 <|> (char '>' >> return (Comment mempty))
210-- | /§8.2.4.47/: Comment start dash state
211commentStartDash :: Parser Token
212commentStartDash =
213 (char '-' >> commentEnd mempty)
214 <|> (char '>' >> return (Comment mempty))
215 <|> (do c <- anyChar
216 comment (B.singleton '-' <> B.singleton c) )
218-- | /§8.2.4.48/: Comment state
219comment :: Builder -> Parser Token
220comment content0 = do
221 content <- B.fromText <$> takeWhile (notInClass "-")
222 id $ (char '-' >> commentEndDash (content0 <> content))
223 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
225-- | /§8.2.4.49/: Comment end dash state
226commentEndDash :: Builder -> Parser Token
227commentEndDash content = do
228 (char '-' >> commentEnd content)
229 <|> (char '\x00' >> comment (content <> "-\xfffd"))
230 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
232-- | /§8.2.4.50/: Comment end state
233commentEnd :: Builder -> Parser Token
234commentEnd content = do
235 (char '>' >> return (Comment content))
236 <|> (char '\x00' >> comment (content <> "-\xfffd"))
237 -- <|> () TODO: other cases
238 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
240-- | /§8.2.4.52/: DOCTYPE state
241-- FIXME
242doctype :: Parser Token
243doctype = do
244 content <- takeTill (=='>')
245 char '>'
246 return $ Doctype content
248-- | /§8.2.4.44/: Bogus comment state
249bogusComment :: Parser Token
250bogusComment = fail "Bogus comment"
252-- | Parse a lazy list of tokens from strict 'Text'.
253parseTokens :: Text -> [Token]
254parseTokens = unfoldr f
255 where
256 f :: Text -> Maybe (Token, Text)
257 f t
258 | T.null t = Nothing
259 | otherwise =
260 case parse token t of
261 Done rest tok -> Just (tok, rest)
262 _ -> Nothing
264-- | Parse a lazy list of tokens from lazy 'TL.Text'.
265parseTokensLazy :: TL.Text -> [Token]
266parseTokensLazy = unfoldr f
267 where
268 f :: TL.Text -> Maybe (Token, TL.Text)
269 f t
270 | TL.null t = Nothing
271 | otherwise =
272 case AL.parse token t of
273 AL.Done rest tok -> Just (tok, rest)
274 _ -> Nothing