git.iko.soy/typeable/html-parse
on master help sign in
Merge pull request #6 from zerobuzz/trees

Parsing and rendering for token trees and forests.

commit801d8613a7d655156de6acca3953a87a57101025 authorBen Gamari <ben@smart-cactus.org> dateThu 5 Jan 2017, 19:00 (10 years ago) parentaf5d28d2ad3c5a
4 files changed+121−4
compare with master
unifiedsplit
Text/HTML/Tree.hs+70 html-parse.cabal+6−3 tests/Text/HTML/ParserSpec.hs+1−1 tests/Text/HTML/TreeSpec.hs+44
Text/HTML/Tree.hsnew file+70
@@ -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
2626 location: git://github.com/bgamari/html-parse
2727
2828library
29− exposed-modules: Text.HTML.Parser
29+ exposed-modules: Text.HTML.Parser, Text.HTML.Tree
3030 other-extensions: OverloadedStrings, DeriveGeneric
3131 build-depends: base >=4.7 && <4.10,
3232 deepseq >=1.4 && <1.5,
3333 attoparsec >=0.13 && <0.14,
34− text >=1.2 && <1.3
34+ text >=1.2 && <1.3,
35+ containers >=0.5 && <0.6
3536 default-language: Haskell2010
3637
3738benchmark bench
@@ -48,10 +49,12 @@ benchmark bench
4849
4950test-suite spec
5051 type: exitcode-stdio-1.0
51− main-is: Spec.hs
5252 hs-source-dirs: tests
53+ main-is: Spec.hs
54+ other-modules: Text.HTML.ParserSpec, Text.HTML.TreeSpec
5355 ghc-options: -Wall -with-rtsopts=-T
5456 build-depends: base,
57+ containers,
5558 hspec,
5659 hspec-discover,
5760 html-parse,
tests/Text/HTML/ParserSpec.hs+1−1
@@ -4,7 +4,7 @@
44{-# LANGUAGE ScopedTypeVariables #-}
55{-# LANGUAGE ViewPatterns #-}
66
7−{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-}
7+{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -fno-warn-unused-imports #-}
88
99module Text.HTML.ParserSpec
1010where
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