git.iko.soy/typeable/html-parse
on a934786 help sign in
typeable/html-parse/Text/HTML/Tree.hs
70 lines 2.4 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ViewPatterns #-}
4module Text.HTML.Tree
5 ( -- * Constructing forests
6 tokensToForest
7 , ParseTokenForestError(..), PStack(..)
8 , nonClosing
9 -- * Deconstructing forests
10 , tokensFromForest
11 , tokensFromTree
12 ) where
14import Data.Monoid
15import Data.Text (Text)
16import Data.Tree
17import Text.HTML.Parser
20tokensToForest :: [Token] -> Either ParseTokenForestError (Forest Token)
21tokensToForest = 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
35nonClosing :: [Text]
36nonClosing = ["br", "hr", "img"]
38data ParseTokenForestError =
39 ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
40 deriving (Eq, Show)
42data PStack = PStack
43 { _pstackToplevelSiblings :: Forest Token
44 , _pstackParents :: [(Token, Forest Token)]
45 }
46 deriving (Eq, Show)
48pushParent :: Token -> PStack -> PStack
49pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
51popParent :: TagName -> PStack -> Either ParseTokenForestError PStack
52popParent n (PStack ss ((p@(TagOpen n' _), ss') : ps))
53 | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
54popParent n pstack
55 = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
57pushFlatSibling :: Token -> PStack -> PStack
58pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
61tokensFromForest :: Forest Token -> [Token]
62tokensFromForest = mconcat . fmap tokensFromTree
64tokensFromTree :: Tree Token -> [Token]
65tokensFromTree (Node o@(TagOpen n _) ts) | n `notElem` nonClosing
66 = [o] <> tokensFromForest ts <> [TagClose n]
67tokensFromTree (Node t [])
68 = [t]
69tokensFromTree _
70 = error "renderTokenTree: leaf node with children."