git.iko.soy/typeable/html-parse
on 4822494 help sign in
typeable/html-parse/Text/HTML/Parser.hs
251 lines 8.2 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 ( TagName, AttrName, AttrValue
10 , Token(..)
11 , Attr(..)
12 , token
13 , tagStream
14 ) where
16import Data.Char hiding (isSpace)
17import Data.List (unfoldr)
18import GHC.Generics
19import Control.Applicative
20import Data.Monoid
21import Control.Monad (guard)
22import Control.DeepSeq
24import Data.Attoparsec.Text
25import Data.Text (Text)
26import qualified Data.Text as T
27import Data.Text.Lazy.Builder (Builder)
28import qualified Data.Text.Lazy.Builder as B
29import Prelude hiding (take, takeWhile)
31type TagName = Text
32type AttrName = Text
33type AttrValue = Text
35-- | An HTML token
36data Token
37 -- | An opening tag. Attribute ordering is arbitrary
38 = TagOpen !TagName [Attr]
39 -- | A closing tag.
40 | TagClose !TagName
41 -- | The content between tags.
42 | ContentChar !Char
43 | ContentText !Text
44 -- | Contents of a comment.
45 | Comment !Builder
46 -- | Doctype
47 | Doctype !Text
48 deriving (Show, Ord, Eq, Generic)
50-- | An attribute of a tag
51data Attr = Attr !AttrName !AttrValue
52 deriving (Show, Eq, Ord)
54instance NFData Token where
55 rnf (Comment b) = rnf $ B.toLazyText b
56 rnf _ = ()
58-- | Parse a single 'Token'.
59token :: Parser Token
60token = dataState -- Start in the data state.
62-- | /§8.2.4.1/: Data state
63dataState :: Parser Token
64dataState = do
65 content <- takeWhile (/= '<')
66 if not $ T.null content
67 then return $ ContentText content
68 else char '<' >> tagOpen
70-- | /§8.2.4.3/: Tag open state
71tagOpen :: Parser Token
72tagOpen =
73 (char '!' >> markupDeclOpen)
74 <|> (char '/' >> endTagOpen)
75 <|> (char '?' >> bogusComment)
76 <|> tryStartTag
77 <|> other
78 where
79 tryStartTag = do
80 c <- peekChar'
81 guard $ isAsciiUpper c || isAsciiLower c
82 tagName
84 other = do
85 return $ ContentChar '<'
87-- | /§8.2.4.9/: End tag open state
88-- TODO: This isn't right
89endTagOpen :: Parser Token
90endTagOpen = do
91 name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
92 char '>'
93 return $ TagClose name
95-- | /§8.2.4.10/: Tag name state
96--
97-- deviation: no lower-casing
98tagName :: Parser Token
99tagName = do
100 tag <- takeWhile $ notInClass "\x09\x0a\x0c />"
101 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
102 <|> (char '/' >> selfClosingStartTag tag [])
103 <|> (char '>' >> return (TagOpen tag []))
105-- | /§8.2.4.43/: Self-closing start tag state
106selfClosingStartTag :: TagName -> [Attr] -> Parser Token
107selfClosingStartTag tag attrs = do
108 (char '>' >> return (TagOpen tag attrs))
109 <|> beforeAttrName tag attrs
111-- | /§8.2.4.34/: Before attribute name state
112--
113-- deviation: no lower-casing
114beforeAttrName :: TagName -> [Attr] -> Parser Token
115beforeAttrName tag attrs = do
116 skipWhile $ inClass "\x09\x0a\x0c "
117 id $ (char '/' >> selfClosingStartTag tag attrs)
118 <|> (char '>' >> return (TagOpen tag attrs))
119 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
120 <|> attrName tag attrs
122-- | /§8.2.4.35/: Attribute name state
123attrName :: TagName -> [Attr] -> Parser Token
124attrName tag attrs = do
125 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
126 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
127 <|> (char '/' >> selfClosingStartTag tag attrs)
128 <|> (char '=' >> beforeAttrValue tag attrs name)
129 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
130 -- <|> -- TODO: NULL
132-- | /§8.2.4.36/: After attribute name state
133afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
134afterAttrName tag attrs name = do
135 skipWhile $ inClass "\x09\x0a\x0c "
136 id $ (char '/' >> selfClosingStartTag tag attrs)
137 <|> (char '=' >> beforeAttrValue tag attrs name)
138 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
139 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
141-- | /§8.2.4.37/: Before attribute value state
142beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
143beforeAttrValue tag attrs name = do
144 skipWhile $ inClass "\x09\x0a\x0c "
145 id $ (char '"' >> attrValueDQuoted tag attrs name)
146 <|> (char '\'' >> attrValueSQuoted tag attrs name)
147 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
148 <|> attrValueUnquoted tag attrs name
150-- | /§8.2.4.38/: Attribute value (double-quoted) state
151attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
152attrValueDQuoted tag attrs name = do
153 value <- takeWhile (/= '"')
154 char '"'
155 afterAttrValueQuoted tag attrs name value
157-- | /§8.2.4.39/: Attribute value (single-quoted) state
158attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
159attrValueSQuoted tag attrs name = do
160 value <- takeWhile (/= '\'')
161 char '\''
162 afterAttrValueQuoted tag attrs name value
164-- | /§8.2.4.40/: Attribute value (unquoted) state
165attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
166attrValueUnquoted tag attrs name = do
167 value <- takeTill (inClass "\x09\x0a\x0c >")
168 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
169 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
171-- | /§8.2.4.42/: After attribute value (quoted) state
172afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
173afterAttrValueQuoted tag attrs name value =
174 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
175 <|> (char '/' >> selfClosingStartTag tag attrs')
176 <|> (char '>' >> return (TagOpen tag attrs'))
177 where attrs' = Attr name value : attrs
179-- | /§8.2.4.45/: Markup declaration open state
180markupDeclOpen :: Parser Token
181markupDeclOpen =
182 try comment
183 <|> try docType
184 -- TODO: Fix the rest
185 where
186 comment = string "--" >> commentStart
187 docType = do
188 -- switching this to asciiCI slowed things down by a factor of two
189 s <- take 7
190 guard $ T.toLower s == "doctype"
191 doctype
193-- | /§8.2.4.46/: Comment start state
194commentStart :: Parser Token
195commentStart = do
196 (char '-' >> commentStartDash)
197 <|> (char '>' >> return (Comment mempty))
199-- | /§8.2.4.47/: Comment start dash state
200commentStartDash :: Parser Token
201commentStartDash =
202 (char '-' >> commentEnd mempty)
203 <|> (char '>' >> return (Comment mempty))
204 <|> (do c <- anyChar
205 comment (B.singleton '-' <> B.singleton c) )
207-- | /§8.2.4.48/: Comment state
208comment :: Builder -> Parser Token
209comment content0 = do
210 content <- B.fromText <$> takeWhile (notInClass "-")
211 id $ (char '-' >> commentEndDash (content0 <> content))
212 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
214-- | /§8.2.4.49/: Comment end dash state
215commentEndDash :: Builder -> Parser Token
216commentEndDash content = do
217 (char '-' >> commentEnd content)
218 <|> (char '\x00' >> comment (content <> "-\xfffd"))
219 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
221-- | /§8.2.4.50/: Comment end state
222commentEnd :: Builder -> Parser Token
223commentEnd content = do
224 (char '>' >> return (Comment content))
225 <|> (char '\x00' >> comment (content <> "-\xfffd"))
226 -- <|> () TODO: other cases
227 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
229-- | /§8.2.4.52/: DOCTYPE state
230-- FIXME
231doctype :: Parser Token
232doctype = do
233 content <- takeTill (=='>')
234 char '>'
235 return $ Doctype content
237-- | /§8.2.4.44/: Bogus comment state
238bogusComment :: Parser Token
239bogusComment = fail "Bogus comment"
241-- | Produce a lazy list of tokens.
242tagStream :: Text -> [Token]
243tagStream = unfoldr f
244 where
245 f :: Text -> Maybe (Token, Text)
246 f t
247 | T.null t = Nothing
248 | otherwise =
249 case parse token t of
250 Done rest tok -> Just (tok, rest)
251 _ -> Nothing