git.iko.soy/typeable/html-parse
on master help sign in
Fix non-closing tags.
a934786Matthias Fischmann
Text/HTML/Tree.hs+9−5
compare with master
unifiedsplit
@@ -5,12 +5,14 @@ module Text.HTML.Tree
5 ( -- * Constructing forests
5 ( -- * Constructing forests
6 tokensToForest
6 tokensToForest
7 , ParseTokenForestError(..), PStack(..)
7 , ParseTokenForestError(..), PStack(..)
8+ , nonClosing
8 -- * Deconstructing forests
9 -- * Deconstructing forests
9 , tokensFromForest
10 , tokensFromForest
10 , tokensFromTree
11 , tokensFromTree
11 ) where
12 ) where
12
13
13import Data.Monoid
14import Data.Monoid
15+import Data.Text (Text)
14import Data.Tree
16import Data.Tree
15import Text.HTML.Parser
17import Text.HTML.Parser
16
18
@@ -21,16 +23,18 @@ tokensToForest = f (PStack [] [])
21 f (PStack ss []) [] = Right (reverse ss)
23 f (PStack ss []) [] = Right (reverse ss)
22 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
24 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
23 f pstack (t : ts) = case t of
25 f pstack (t : ts) = case t of
24− TagOpen "br" _ -> f (pushFlatSibling t pstack) ts
26+ TagOpen n _ -> if n `elem` nonClosing
25− TagOpen "hr" _ -> f (pushFlatSibling t pstack) ts
27+ then f (pushFlatSibling t pstack) ts
26− TagOpen "img" _ -> f (pushFlatSibling t pstack) ts
27− TagOpen _ _ -> f (pushParent t pstack) ts
28+ else f (pushParent t pstack) ts
28 TagClose n -> (`f` ts) =<< popParent n pstack
29 TagClose n -> (`f` ts) =<< popParent n pstack
29 ContentChar _ -> f (pushFlatSibling t pstack) ts
30 ContentChar _ -> f (pushFlatSibling t pstack) ts
30 ContentText _ -> f (pushFlatSibling t pstack) ts
31 ContentText _ -> f (pushFlatSibling t pstack) ts
31 Comment _ -> f (pushFlatSibling t pstack) ts
32 Comment _ -> f (pushFlatSibling t pstack) ts
32 Doctype _ -> f (pushFlatSibling t pstack) ts
33 Doctype _ -> f (pushFlatSibling t pstack) ts
33
34
35+nonClosing :: [Text]
36+nonClosing = ["br", "hr", "img"]
37+
34data ParseTokenForestError =
38data ParseTokenForestError =
35 ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
39 ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
36 deriving (Eq, Show)
40 deriving (Eq, Show)
@@ -58,7 +62,7 @@ tokensFromForest :: Forest Token -> [Token]
58tokensFromForest = mconcat . fmap tokensFromTree
62tokensFromForest = mconcat . fmap tokensFromTree
59
63
60tokensFromTree :: Tree Token -> [Token]
64tokensFromTree :: Tree Token -> [Token]
61−tokensFromTree (Node o@(TagOpen n _) ts)
65+tokensFromTree (Node o@(TagOpen n _) ts) | n `notElem` nonClosing
62 = [o] <> tokensFromForest ts <> [TagClose n]
66 = [o] <> tokensFromForest ts <> [TagClose n]
63tokensFromTree (Node t [])
67tokensFromTree (Node t [])
64 = [t]
68 = [t]
tests/Text/HTML/TreeSpec.hs+14−2
@@ -1,4 +1,5 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3
4
4{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
5{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
@@ -20,11 +21,22 @@ arbitraryTokenForest = listOf arbitraryTokenTree
20
21
21arbitraryTokenTree :: Gen (Tree Token)
22arbitraryTokenTree :: Gen (Tree Token)
22arbitraryTokenTree = oneof
23arbitraryTokenTree = oneof
23− [ Node <$> validOpen <*> scale (`div` 5) arbitraryTokenForest
24+ [ Node <$> validClosingOpen <*> scale (`div` 5) arbitraryTokenForest
25+ , Node <$> validNonClosingOpen <*> pure []
24− , Node <$> validFlat <*> pure []
26+ , Node <$> validFlat <*> pure []
25 ]
27 ]
26
28
27
29
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+
28spec :: Spec
40spec :: Spec
29spec = do
41spec = do
30 it "parseTokenForests and renderTokenForest are inverses"
42 it "parseTokenForests and renderTokenForest are inverses"