78ce9ca · typeable/html-parse

107

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

109--

110−-- deviation: no lower-casing

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

111tagNameOpen :: Parser Token

112tagNameOpen = do

113 tag <- tagName'

123

124-- | /§8.2.4.10/: Tag name state: common code

125--

126−-- deviation: no lower-casing

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

127tagName' :: Parser Text

128tagName' = do

129 c <- peekChar'

130 guard $ isAsciiUpper c || isAsciiLower c

131 takeWhile $ notInClass "\x09\x0a\x0c /<>"

132

133−-- | /§8.2.4.43/: Self-closing start tag state

133+-- | /§8.2.4.40/: Self-closing start tag state

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

135selfClosingStartTag tag attrs = do

136 (char '>' >> return (TagSelfClose tag attrs))

137 <|> beforeAttrName tag attrs

138

139−-- | /§8.2.4.34/: Before attribute name state

139+-- | /§8.2.4.32/: Before attribute name state

140--

141-- deviation: no lower-casing

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

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

148 <|> attrName tag attrs

149

150−-- | /§8.2.4.35/: Attribute name state

150+-- | /§8.2.4.33/: Attribute name state

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

152attrName tag attrs = do

153 name <- takeWhile $ notInClass "\x09\x0a\x0c /=<>\x00"

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

158 -- <|> -- TODO: NULL

159

160−-- | /§8.2.4.36/: After attribute name state

160+-- | /§8.2.4.34/: After attribute name state

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

162afterAttrName tag attrs name = do

163 skipWhile $ inClass "\x09\x0a\x0c "

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

167 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right

168

169−-- | /§8.2.4.37/: Before attribute value state

169+-- | /§8.2.4.35/: Before attribute value state

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

171beforeAttrValue tag attrs name = do

172 skipWhile $ inClass "\x09\x0a\x0c "

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

176 <|> attrValueUnquoted tag attrs name

177

178−-- | /§8.2.4.38/: Attribute value (double-quoted) state

178+-- | /§8.2.4.36/: Attribute value (double-quoted) state

179attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token

180attrValueDQuoted tag attrs name = do

181 value <- takeWhile (/= '"')

182 _ <- char '"'

183 afterAttrValueQuoted tag attrs name value

184

185−-- | /§8.2.4.39/: Attribute value (single-quoted) state

185+-- | /§8.2.4.37/: Attribute value (single-quoted) state

186attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token

187attrValueSQuoted tag attrs name = do

188 value <- takeWhile (/= '\'')

189 _ <- char '\''

190 afterAttrValueQuoted tag attrs name value

191

192−-- | /§8.2.4.40/: Attribute value (unquoted) state

192+-- | /§8.2.4.38/: Attribute value (unquoted) state

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

194attrValueUnquoted tag attrs name = do

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

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

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

198

199−-- | /§8.2.4.42/: After attribute value (quoted) state

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

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

201afterAttrValueQuoted tag attrs name value =

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

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

205 where attrs' = Attr name value : attrs

206

207+-- | /§8.2.4.41/: Bogus comment state

208+bogusComment :: Builder -> Parser Token

209+bogusComment content = do

210+ (char '>' >> return (Comment content))

211+ <|> (endOfInput >> return (Comment content))

212+ <|> (char '\x00' >> bogusComment (content <> "\xfffd"))

213+ <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))

214+

207-- | /§8.2.4.42/: Markup declaration open state

215-- | /§8.2.4.42/: Markup declaration open state

208markupDeclOpen :: Parser Token

216markupDeclOpen :: Parser Token

209markupDeclOpen =

217markupDeclOpen =

297 _ <- char '>'

305 _ <- char '>'

298 return $ Doctype content

306 return $ Doctype content

299

307

300−-- | /§8.2.4.41/: Bogus comment state

301−bogusComment :: Builder -> Parser Token

302−bogusComment content = do

303− (char '>' >> return (Comment content))

304− <|> (endOfInput >> return (Comment content))

305− <|> (char '\x00' >> bogusComment (content <> "\xfffd"))

306− <|> (anyChar >>= \c -> bogusComment (content <> B.singleton c))

307−

308-- | Parse a lazy list of tokens from strict 'Text'.

309parseTokens :: Text -> [Token]

310parseTokens = unfoldr f