git.iko.soy/typeable/html-parse
on master help sign in
Fix non-closing tags.
commita93478667e0454fede312f09d6741a0a55bb03ba authorMatthias Fischmann <mf@zerobuzz.net> dateSun 1 Jan 2017, 09:09 (10 years ago) parent9f62344
2 files changed+23−7
compare with master
unifiedsplit
Text/HTML/Tree.hs+9−5 tests/Text/HTML/TreeSpec.hs+14−2
Text/HTML/Tree.hs+9−5
@@ -5,12 +5,14 @@ module Text.HTML.Tree
55 ( -- * Constructing forests
66 tokensToForest
77 , ParseTokenForestError(..), PStack(..)
8+ , nonClosing
89 -- * Deconstructing forests
910 , tokensFromForest
1011 , tokensFromTree
1112 ) where
1213
1314import Data.Monoid
15+import Data.Text (Text)
1416import Data.Tree
1517import Text.HTML.Parser
1618
@@ -21,16 +23,18 @@ tokensToForest = f (PStack [] [])
2123 f (PStack ss []) [] = Right (reverse ss)
2224 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
2325 f pstack (t : ts) = case t of
24− TagOpen "br" _ -> f (pushFlatSibling t pstack) ts
25− TagOpen "hr" _ -> f (pushFlatSibling t pstack) ts
26− TagOpen "img" _ -> f (pushFlatSibling t pstack) ts
27− TagOpen _ _ -> f (pushParent t pstack) ts
26+ TagOpen n _ -> if n `elem` nonClosing
27+ then f (pushFlatSibling t pstack) ts
28+ else f (pushParent t pstack) ts
2829 TagClose n -> (`f` ts) =<< popParent n pstack
2930 ContentChar _ -> f (pushFlatSibling t pstack) ts
3031 ContentText _ -> f (pushFlatSibling t pstack) ts
3132 Comment _ -> f (pushFlatSibling t pstack) ts
3233 Doctype _ -> f (pushFlatSibling t pstack) ts
3334
35+nonClosing :: [Text]
36+nonClosing = ["br", "hr", "img"]
37+
3438data ParseTokenForestError =
3539 ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
3640 deriving (Eq, Show)
@@ -58,7 +62,7 @@ tokensFromForest :: Forest Token -> [Token]
5862tokensFromForest = mconcat . fmap tokensFromTree
5963
6064tokensFromTree :: Tree Token -> [Token]
61−tokensFromTree (Node o@(TagOpen n _) ts)
65+tokensFromTree (Node o@(TagOpen n _) ts) | n `notElem` nonClosing
6266 = [o] <> tokensFromForest ts <> [TagClose n]
6367tokensFromTree (Node t [])
6468 = [t]
tests/Text/HTML/TreeSpec.hs+14−2
@@ -1,4 +1,5 @@
11{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34
45{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
@@ -20,11 +21,22 @@ arbitraryTokenForest = listOf arbitraryTokenTree
2021
2122arbitraryTokenTree :: Gen (Tree Token)
2223arbitraryTokenTree = oneof
23− [ Node <$> validOpen <*> scale (`div` 5) arbitraryTokenForest
24− , Node <$> validFlat <*> pure []
24+ [ Node <$> validClosingOpen <*> scale (`div` 5) arbitraryTokenForest
25+ , Node <$> validNonClosingOpen <*> pure []
26+ , Node <$> validFlat <*> pure []
2527 ]
2628
2729
30+validNonClosingOpen :: Gen Token
31+validNonClosingOpen = TagOpen <$> elements nonClosing <*> arbitrary
32+
33+validClosingOpen :: Gen Token
34+validClosingOpen = do
35+ n <- validXmlTagName
36+ let n' = if n `elem` nonClosing then "_" else n
37+ TagOpen n' <$> arbitrary
38+
39+
2840spec :: Spec
2941spec = do
3042 it "parseTokenForests and renderTokenForest are inverses"