e8a8555 · typeable/html-parse

git.iko.soy/typeable/html-parse

on master help sign in

Merge pull request #12 from zerobuzz/self-closing

e8a8555Ben Gamari10 years ago

Text/HTML/Parser.hs+16−13

compare with master

unifiedsplit

@@ -53,6 +53,8 @@ type AttrValue = Text

53data Token

54 -- | An opening tag. Attribute ordering is arbitrary.

55 = TagOpen !TagName [Attr]

56+ -- | A self-closing tag.

57+ | TagSelfClose !TagName [Attr]

56 -- | A closing tag.

58 -- | A closing tag.

57 | TagClose !TagName

59 | TagClose !TagName

58 -- | The content between tags.

60 -- | The content between tags.

@@ -129,7 +131,7 @@ tagName' = do

129-- | /§8.2.4.43/: Self-closing start tag state

131-- | /§8.2.4.43/: Self-closing start tag state

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

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

131selfClosingStartTag tag attrs = do

133selfClosingStartTag tag attrs = do

132− (char '>' >> return (TagOpen tag attrs))

134+ (char '>' >> return (TagSelfClose tag attrs))

133 <|> beforeAttrName tag attrs

135 <|> beforeAttrName tag attrs

134

136

135-- | /§8.2.4.34/: Before attribute name state

137-- | /§8.2.4.34/: Before attribute name state

@@ -175,14 +177,14 @@ beforeAttrValue tag attrs name = do

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

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

176attrValueDQuoted tag attrs name = do

178attrValueDQuoted tag attrs name = do

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

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

178− char '"'

180+ _ <- char '"'

179 afterAttrValueQuoted tag attrs name value

181 afterAttrValueQuoted tag attrs name value

180

182

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

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

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

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

183attrValueSQuoted tag attrs name = do

185attrValueSQuoted tag attrs name = do

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

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

185− char '\''

187+ _ <- char '\''

186 afterAttrValueQuoted tag attrs name value

188 afterAttrValueQuoted tag attrs name value

187

189

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

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

@@ -203,11 +205,11 @@ afterAttrValueQuoted tag attrs name value =

203-- | /§8.2.4.45/: Markup declaration open state

205-- | /§8.2.4.45/: Markup declaration open state

204markupDeclOpen :: Parser Token

206markupDeclOpen :: Parser Token

205markupDeclOpen =

207markupDeclOpen =

206− try comment

208+ try comment_

207 <|> try docType

209 <|> try docType

208 -- TODO: Fix the rest

210 -- TODO: Fix the rest

209 where

211 where

210− comment = string "--" >> commentStart

212+ comment_ = string "--" >> commentStart

211 docType = do

213 docType = do

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

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

213 s <- take 7

215 s <- take 7

@@ -256,7 +258,7 @@ commentEnd content = do

256doctype :: Parser Token

258doctype :: Parser Token

257doctype = do

259doctype = do

258 content <- takeTill (=='>')

260 content <- takeTill (=='>')

259− char '>'

261+ _ <- char '>'

260 return $ Doctype content

262 return $ Doctype content

261

263

262-- | /§8.2.4.44/: Bogus comment state

264-- | /§8.2.4.44/: Bogus comment state

@@ -298,13 +300,14 @@ renderTokens = mconcat . fmap renderToken

298-- | (Somewhat) canonical string representation of 'Token'.

300-- | (Somewhat) canonical string representation of 'Token'.

299renderToken :: Token -> TL.Text

301renderToken :: Token -> TL.Text

300renderToken = TL.fromStrict . mconcat . \case

302renderToken = TL.fromStrict . mconcat . \case

301− (TagOpen n []) -> ["<", n, ">"]

303+ (TagOpen n []) -> ["<", n, ">"]

304+ (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]

302− (TagOpen n attrs) -> ["<", n, " ", renderAttrs attrs, ">"]

305+ (TagSelfClose n attrs) -> ["<", n, " ", renderAttrs attrs, " />"]

303− (TagClose n) -> ["</", n, ">"]

306+ (TagClose n) -> ["</", n, ">"]

304− (ContentChar c) -> [T.singleton c]

307+ (ContentChar c) -> [T.singleton c]

305− (ContentText t) -> [t]

308+ (ContentText t) -> [t]

306− (Comment builder) -> [""]

309+ (Comment builder) -> [""]

307− (Doctype t) -> ["<!DOCTYPE", t, ">"]

310+ (Doctype t) -> ["<!DOCTYPE", t, ">"]

308

311

309-- | See 'renderAttr'.

312-- | See 'renderAttr'.

310renderAttrs :: [Attr] -> Text

313renderAttrs :: [Attr] -> Text

Text/HTML/Tree.hs+1

@@ -26,6 +26,7 @@ tokensToForest = f (PStack [] [])

26 TagOpen n _ -> if n `elem` nonClosing

27 then f (pushFlatSibling t pstack) ts

28 else f (pushParent t pstack) ts

29+ TagSelfClose {} -> f (pushFlatSibling t pstack) ts

29 TagClose n -> (`f` ts) =<< popParent n pstack

30 TagClose n -> (`f` ts) =<< popParent n pstack

30 ContentChar _ -> f (pushFlatSibling t pstack) ts

31 ContentChar _ -> f (pushFlatSibling t pstack) ts

31 ContentText _ -> f (pushFlatSibling t pstack) ts

32 ContentText _ -> f (pushFlatSibling t pstack) ts

html-parse.cabal+1

@@ -27,6 +27,7 @@ source-repository head

28library

29 exposed-modules: Text.HTML.Parser, Text.HTML.Tree

30+ ghc-options: -Wall

30 other-extensions: OverloadedStrings, DeriveGeneric

31 other-extensions: OverloadedStrings, DeriveGeneric

31 build-depends: base >=4.7 && <4.10,

32 build-depends: base >=4.7 && <4.10,

32 deepseq >=1.4 && <1.5,

33 deepseq >=1.4 && <1.5,

tests/Text/HTML/ParserSpec.hs+9−7

@@ -24,12 +24,13 @@ import Text.HTML.Parser

24instance Arbitrary Token where

25 arbitrary = oneof [validOpen, validClose, validFlat]

27− shrink (TagOpen n as) = TagOpen n <$> shrink as

27+ shrink (TagOpen n as) = TagOpen n <$> shrink as

28+ shrink (TagSelfClose n as) = TagSelfClose n <$> shrink as

28− shrink (TagClose _) = []

29+ shrink (TagClose _) = []

29− shrink (ContentText _) = []

30+ shrink (ContentText _) = []

30− shrink (ContentChar _) = []

31+ shrink (ContentChar _) = []

31− shrink (Comment b) = Comment . B.fromText <$> (shrink . TL.toStrict . B.toLazyText $ b)

32+ shrink (Comment b) = Comment . B.fromText <$> (shrink . TL.toStrict . B.toLazyText $ b)

32− shrink (Doctype t) = Doctype <$> shrink t

33+ shrink (Doctype t) = Doctype <$> shrink t

34instance Arbitrary Attr where

35instance Arbitrary Attr where

35 arbitrary = Attr <$> validXmlAttrName <*> validXmlAttrValue

36 arbitrary = Attr <$> validXmlAttrName <*> validXmlAttrValue

@@ -43,7 +44,8 @@ validClose = TagClose <$> validXmlTagName

44validFlat :: Gen Token

45validFlat :: Gen Token

45validFlat = oneof

46validFlat = oneof

47+ [ TagSelfClose <$> validXmlTagName <*> arbitrary

46− [ ContentChar <$> validXmlChar

48+ , ContentChar <$> validXmlChar

47 , ContentText <$> validXmlText

49 , ContentText <$> validXmlText

48 , Comment . B.fromText <$> validXmlCommentText

50 , Comment . B.fromText <$> validXmlCommentText

49 , Doctype <$> validXmlText

51 , Doctype <$> validXmlText