git.iko.soy/typeable/html-parse
on master help sign in
Merge pull request #6 from zerobuzz/trees
801d861Ben Gamari
Text/HTML/Tree.hsnew file+70
compare with master
unifiedsplit
@@ -0,0 +1,70 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ViewPatterns #-}
3+
4+module Text.HTML.Tree
5+ ( -- * Constructing forests
6+ tokensToForest
7+ , ParseTokenForestError(..), PStack(..)
8+ , nonClosing
9+ -- * Deconstructing forests
10+ , tokensFromForest
11+ , tokensFromTree
12+ ) where
13+
14+import Data.Monoid
15+import Data.Text (Text)
16+import Data.Tree
17+import Text.HTML.Parser
18+
19+
20+tokensToForest :: [Token] -> Either ParseTokenForestError (Forest Token)
21+tokensToForest = f (PStack [] [])
22+ where
23+ f (PStack ss []) [] = Right (reverse ss)
24+ f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
25+ f pstack (t : ts) = case t of
26+ TagOpen n _ -> if n `elem` nonClosing
27+ then f (pushFlatSibling t pstack) ts
28+ else f (pushParent t pstack) ts
29+ TagClose n -> (`f` ts) =<< popParent n pstack
30+ ContentChar _ -> f (pushFlatSibling t pstack) ts
31+ ContentText _ -> f (pushFlatSibling t pstack) ts
32+ Comment _ -> f (pushFlatSibling t pstack) ts
33+ Doctype _ -> f (pushFlatSibling t pstack) ts
34+
35+nonClosing :: [Text]
36+nonClosing = ["br", "hr", "img"]
37+
38+data ParseTokenForestError =
39+ ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
40+ deriving (Eq, Show)
41+
42+data PStack = PStack
43+ { _pstackToplevelSiblings :: Forest Token
44+ , _pstackParents :: [(Token, Forest Token)]
45+ }
46+ deriving (Eq, Show)
47+
48+pushParent :: Token -> PStack -> PStack
49+pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
50+
51+popParent :: TagName -> PStack -> Either ParseTokenForestError PStack
52+popParent n (PStack ss ((p@(TagOpen n' _), ss') : ps))
53+ | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
54+popParent n pstack
55+ = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
56+
57+pushFlatSibling :: Token -> PStack -> PStack
58+pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
59+
60+
61+tokensFromForest :: Forest Token -> [Token]
62+tokensFromForest = mconcat . fmap tokensFromTree
63+
64+tokensFromTree :: Tree Token -> [Token]
65+tokensFromTree (Node o@(TagOpen n _) ts) | n `notElem` nonClosing
66+ = [o] <> tokensFromForest ts <> [TagClose n]
67+tokensFromTree (Node t [])
68+ = [t]
69+tokensFromTree _
70+ = error "renderTokenTree: leaf node with children."
html-parse.cabal+6−3
@@ -26,12 +26,13 @@ source-repository head
26 location: git://github.com/bgamari/html-parse
26 location: git://github.com/bgamari/html-parse
27
27
28library
28library
29− exposed-modules: Text.HTML.Parser
29+ exposed-modules: Text.HTML.Parser, Text.HTML.Tree
30 other-extensions: OverloadedStrings, DeriveGeneric
30 other-extensions: OverloadedStrings, DeriveGeneric
31 build-depends: base >=4.7 && <4.10,
31 build-depends: base >=4.7 && <4.10,
32 deepseq >=1.4 && <1.5,
32 deepseq >=1.4 && <1.5,
33 attoparsec >=0.13 && <0.14,
33 attoparsec >=0.13 && <0.14,
34− text >=1.2 && <1.3
34+ text >=1.2 && <1.3,
35+ containers >=0.5 && <0.6
35 default-language: Haskell2010
36 default-language: Haskell2010
36
37
37benchmark bench
38benchmark bench
@@ -48,10 +49,12 @@ benchmark bench
48
49
49test-suite spec
50test-suite spec
50 type: exitcode-stdio-1.0
51 type: exitcode-stdio-1.0
51− main-is: Spec.hs
52 hs-source-dirs: tests
52 hs-source-dirs: tests
53+ main-is: Spec.hs
54+ other-modules: Text.HTML.ParserSpec, Text.HTML.TreeSpec
53 ghc-options: -Wall -with-rtsopts=-T
55 ghc-options: -Wall -with-rtsopts=-T
54 build-depends: base,
56 build-depends: base,
57+ containers,
55 hspec,
58 hspec,
56 hspec-discover,
59 hspec-discover,
57 html-parse,
60 html-parse,
tests/Text/HTML/ParserSpec.hs+1−1
@@ -4,7 +4,7 @@
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ViewPatterns #-}
5{-# LANGUAGE ViewPatterns #-}
6
6
7−{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
7+{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -fno-warn-unused-imports #-}
8
8
9module Text.HTML.ParserSpec
9module Text.HTML.ParserSpec
10where
10where
tests/Text/HTML/TreeSpec.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
6+
7+module Text.HTML.TreeSpec
8+where
9+
10+import Data.Tree
11+import Test.Hspec
12+import Test.QuickCheck
13+import Test.QuickCheck.Instances ()
14+import Text.HTML.Parser
15+import Text.HTML.ParserSpec
16+import Text.HTML.Tree
17+
18+
19+arbitraryTokenForest :: Gen (Forest Token)
20+arbitraryTokenForest = listOf arbitraryTokenTree
21+
22+arbitraryTokenTree :: Gen (Tree Token)
23+arbitraryTokenTree = oneof
24+ [ Node <$> validClosingOpen <*> scale (`div` 5) arbitraryTokenForest
25+ , Node <$> validNonClosingOpen <*> pure []
26+ , Node <$> validFlat <*> pure []
27+ ]
28+
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+
40+spec :: Spec
41+spec = do
42+ it "parseTokenForests and renderTokenForest are inverses"
43+ . property . forAllShrink arbitraryTokenForest shrink $
44+ \forest -> tokensToForest (tokensFromForest forest) `shouldBe` Right forest