4420044 · typeable/html-parse

git.iko.soy/typeable/html-parse

on master help sign in

Merge commit 'b426b3e9602fcc8b5df6c8da66935c854536f376'

4420044Ben Gamari9 years ago

Text/HTML/Parser.hs+26−10

compare with master

unifiedsplit

@@ -109,13 +109,29 @@ tagOpen =

109endTagOpen :: Parser Token

110endTagOpen = tagNameClose

111

112+-- | Equivalent to @inClass "\x09\x0a\x0c "@

113+isWhitespace :: Char -> Bool

114+isWhitespace '\x09' = True

115+isWhitespace '\x0a' = True

116+isWhitespace '\x0c' = True

117+isWhitespace ' ' = True

118+isWhitespace _ = False

119+

120+orC :: (Char -> Bool) -> (Char -> Bool) -> Char -> Bool

121+orC f g c = f c || g c

122+{-# INLINE orC #-}

123+

124+isC :: Char -> Char -> Bool

125+isC = (==)

126+{-# INLINE isC #-}

127+

112-- | /§8.2.4.8/: Tag name state: the open case

128-- | /§8.2.4.8/: Tag name state: the open case

113--

129--

114-- deviation: no lower-casing, don't handle NULL characters

130-- deviation: no lower-casing, don't handle NULL characters

115tagNameOpen :: Parser Token

131tagNameOpen :: Parser Token

116tagNameOpen = do

132tagNameOpen = do

117 tag <- tagName'

133 tag <- tagName'

118− id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])

134+ id $ (satisfy isWhitespace >> beforeAttrName tag [])

119 <|> (char '/' >> selfClosingStartTag tag [])

135 <|> (char '/' >> selfClosingStartTag tag [])

120 <|> (char '>' >> return (TagOpen tag []))

136 <|> (char '>' >> return (TagOpen tag []))

121

137

@@ -132,7 +148,7 @@ tagName' :: Parser Text

132tagName' = do

148tagName' = do

133 c <- peekChar'

149 c <- peekChar'

134 guard $ isAsciiUpper c || isAsciiLower c

150 guard $ isAsciiUpper c || isAsciiLower c

135− takeWhile $ notInClass "\x09\x0a\x0c /<>"

151+ takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '<' `orC` isC '>')

136

152

137-- | /§8.2.4.40/: Self-closing start tag state

153-- | /§8.2.4.40/: Self-closing start tag state

138selfClosingStartTag :: TagName -> [Attr] -> Parser Token

154selfClosingStartTag :: TagName -> [Attr] -> Parser Token

@@ -146,7 +162,7 @@ selfClosingStartTag tag attrs = do

146-- deviation: no lower-casing

162-- deviation: no lower-casing

147beforeAttrName :: TagName -> [Attr] -> Parser Token

163beforeAttrName :: TagName -> [Attr] -> Parser Token

148beforeAttrName tag attrs = do

164beforeAttrName tag attrs = do

149− skipWhile $ inClass "\x09\x0a\x0c "

165+ skipWhile isWhitespace

150 id $ (char '/' >> selfClosingStartTag tag attrs)

166 id $ (char '/' >> selfClosingStartTag tag attrs)

151 <|> (char '>' >> return (TagOpen tag attrs))

167 <|> (char '>' >> return (TagOpen tag attrs))

152 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL

168 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL

@@ -155,7 +171,7 @@ beforeAttrName tag attrs = do

155-- | /§8.2.4.33/: Attribute name state

171-- | /§8.2.4.33/: Attribute name state

156attrName :: TagName -> [Attr] -> Parser Token

172attrName :: TagName -> [Attr] -> Parser Token

157attrName tag attrs = do

173attrName tag attrs = do

158− name <- takeWhile $ notInClass "\x09\x0a\x0c /=>"

174+ name <- takeWhile $ not . (isWhitespace `orC` isC '/' `orC` isC '=' `orC` isC '>')

159 id $ (endOfInput >> afterAttrName tag attrs name)

175 id $ (endOfInput >> afterAttrName tag attrs name)

160 <|> (char '=' >> beforeAttrValue tag attrs name)

176 <|> (char '=' >> beforeAttrValue tag attrs name)

161 <|> try (do mc <- peekChar

177 <|> try (do mc <- peekChar

@@ -167,7 +183,7 @@ attrName tag attrs = do

167-- | /§8.2.4.34/: After attribute name state

183-- | /§8.2.4.34/: After attribute name state

168afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token

184afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token

169afterAttrName tag attrs name = do

185afterAttrName tag attrs name = do

170− skipWhile $ inClass "\x09\x0a\x0c "

186+ skipWhile isWhitespace

171 id $ (char '/' >> selfClosingStartTag tag attrs)

187 id $ (char '/' >> selfClosingStartTag tag attrs)

172 <|> (char '=' >> beforeAttrValue tag attrs name)

188 <|> (char '=' >> beforeAttrValue tag attrs name)

173 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

189 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

@@ -177,7 +193,7 @@ afterAttrName tag attrs name = do

177-- | /§8.2.4.35/: Before attribute value state

193-- | /§8.2.4.35/: Before attribute value state

178beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token

194beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token

179beforeAttrValue tag attrs name = do

195beforeAttrValue tag attrs name = do

180− skipWhile $ inClass "\x09\x0a\x0c "

196+ skipWhile isWhitespace

181 id $ (char '"' >> attrValueDQuoted tag attrs name)

197 id $ (char '"' >> attrValueDQuoted tag attrs name)

182 <|> (char '\'' >> attrValueSQuoted tag attrs name)

198 <|> (char '\'' >> attrValueSQuoted tag attrs name)

183 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

199 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))

@@ -201,14 +217,14 @@ attrValueSQuoted tag attrs name = do

201attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token

217attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token

202attrValueUnquoted tag attrs name = do

218attrValueUnquoted tag attrs name = do

203 value <- takeTill (inClass "\x09\x0a\x0c >")

219 value <- takeTill (inClass "\x09\x0a\x0c >")

204− id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?

220+ id $ (satisfy isWhitespace >> beforeAttrName tag attrs) -- unsure: don't emit?

205 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))

221 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))

206 <|> (endOfInput >> return endOfFileToken)

222 <|> (endOfInput >> return endOfFileToken)

207

223

208-- | /§8.2.4.39/: After attribute value (quoted) state

224-- | /§8.2.4.39/: After attribute value (quoted) state

209afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token

225afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token

210afterAttrValueQuoted tag attrs name value =

226afterAttrValueQuoted tag attrs name value =

211− (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')

227+ (satisfy isWhitespace >> beforeAttrName tag attrs')

212 <|> (char '/' >> selfClosingStartTag tag attrs')

228 <|> (char '/' >> selfClosingStartTag tag attrs')

213 <|> (char '>' >> return (TagOpen tag attrs'))

229 <|> (char '>' >> return (TagOpen tag attrs'))

214 <|> (endOfInput >> return endOfFileToken)

230 <|> (endOfInput >> return endOfFileToken)

@@ -229,7 +245,7 @@ markupDeclOpen =

229 <|> try docType

245 <|> try docType

230 <|> bogusComment mempty

246 <|> bogusComment mempty

231 where

247 where

232− comment_ = string "--" >> commentStart

248+ comment_ = char '-' >> char '-' >> commentStart

233 docType = do

249 docType = do

234 -- switching this to asciiCI slowed things down by a factor of two

250 -- switching this to asciiCI slowed things down by a factor of two

235 s <- take 7

251 s <- take 7

@@ -254,7 +270,7 @@ commentStartDash =

254-- | /§8.2.4.45/: Comment state

270-- | /§8.2.4.45/: Comment state

255comment :: Builder -> Parser Token

271comment :: Builder -> Parser Token

256comment content0 = do

272comment content0 = do

257− content <- B.fromText <$> takeWhile (notInClass "-\x00<")

273+ content <- B.fromText <$> takeWhile (not . (isC '-' `orC` isC '\x00' `orC` isC '<'))

258 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))

274 id $ (char '<' >> commentLessThan (content0 <> content <> "<"))

259 <|> (char '-' >> commentEndDash (content0 <> content))

275 <|> (char '-' >> commentEndDash (content0 <> content))

260 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))

276 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))