e8a8555 · typeable/html-parse

git.iko.soy/typeable/html-parse

Merge pull request #12 from zerobuzz/self-closing

Self closing tags

commite8a855562f7880c5b856342e4f2ddf7a2fb573f0 authorBen Gamari <ben@smart-cactus.org> dateThu 5 Jan 2017, 19:50 (10 years ago) parent801d861 9fe35de

4 files changed+27−20

compare with master

unifiedsplit

Text/HTML/Parser.hs+16−13 Text/HTML/Tree.hs+1 html-parse.cabal+1 tests/Text/HTML/ParserSpec.hs+9−7

Text/HTML/Parser.hs+16−13

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

5353data Token

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

5555 = TagOpen !TagName [Attr]

56+ -- | A self-closing tag.

57+ | TagSelfClose !TagName [Attr]

5658 -- | A closing tag.

5759 | TagClose !TagName

5860 -- | The content between tags.

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

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

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

131133selfClosingStartTag tag attrs = do

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

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

133135 <|> beforeAttrName tag attrs

134136

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

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

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

176178attrValueDQuoted tag attrs name = do

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

178− char '"'

180+ _ <- char '"'

179181 afterAttrValueQuoted tag attrs name value

180182

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

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

183185attrValueSQuoted tag attrs name = do

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

185− char '\''

187+ _ <- char '\''

186188 afterAttrValueQuoted tag attrs name value

187189

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

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

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

204206markupDeclOpen :: Parser Token

205207markupDeclOpen =

206− try comment

208+ try comment_

207209 <|> try docType

208210 -- TODO: Fix the rest

209211 where

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

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

211213 docType = do

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

213215 s <- take 7

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

256258doctype :: Parser Token

257259doctype = do

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

259− char '>'

261+ _ <- char '>'

260262 return $ Doctype content

261263

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

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

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

299301renderToken :: Token -> TL.Text

300302renderToken = TL.fromStrict . mconcat . \case

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

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

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

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

305− (ContentText t) -> [t]

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

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

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

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

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

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

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

308+ (ContentText t) -> [t]

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

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

308311

309312-- | See 'renderAttr'.

310313renderAttrs :: [Attr] -> Text

Text/HTML/Tree.hs+1

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

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

2727 then f (pushFlatSibling t pstack) ts

2828 else f (pushParent t pstack) ts

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

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

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

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

html-parse.cabal+1

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

2727

2828library

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

30+ ghc-options: -Wall

3031 other-extensions: OverloadedStrings, DeriveGeneric

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

3233 deepseq >=1.4 && <1.5,

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

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

2424instance Arbitrary Token where

2525 arbitrary = oneof [validOpen, validClose, validFlat]

2626

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

28− shrink (TagClose _) = []

29− shrink (ContentText _) = []

30− shrink (ContentChar _) = []

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

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

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

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

29+ shrink (TagClose _) = []

30+ shrink (ContentText _) = []

31+ shrink (ContentChar _) = []

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

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

3334

3435instance Arbitrary Attr where

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

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

4344

4445validFlat :: Gen Token

4546validFlat = oneof

46− [ ContentChar <$> validXmlChar

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

48+ , ContentChar <$> validXmlChar

4749 , ContentText <$> validXmlText

4850 , Comment . B.fromText <$> validXmlCommentText

4951 , Doctype <$> validXmlText