git.iko.soy/typeable/html-parse
on 720f954 help sign in
typeable/html-parse/Text/HTML/Tree.hs
71 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 TagSelfClose {} -> f (pushFlatSibling t pstack) ts
30 TagClose n -> (`f` ts) =<< popParent n pstack
31 ContentChar _ -> f (pushFlatSibling t pstack) ts
32 ContentText _ -> f (pushFlatSibling t pstack) ts
33 Comment _ -> f (pushFlatSibling t pstack) ts
34 Doctype _ -> f (pushFlatSibling t pstack) ts
36nonClosing :: [Text]
37nonClosing = ["br", "hr", "img"]
39data ParseTokenForestError =
40 ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
41 deriving (Eq, Show)
43data PStack = PStack
44 { _pstackToplevelSiblings :: Forest Token
45 , _pstackParents :: [(Token, Forest Token)]
46 }
47 deriving (Eq, Show)
49pushParent :: Token -> PStack -> PStack
50pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
52popParent :: TagName -> PStack -> Either ParseTokenForestError PStack
53popParent n (PStack ss ((p@(TagOpen n' _), ss') : ps))
54 | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
55popParent n pstack
56 = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
58pushFlatSibling :: Token -> PStack -> PStack
59pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
62tokensFromForest :: Forest Token -> [Token]
63tokensFromForest = mconcat . fmap tokensFromTree
65tokensFromTree :: Tree Token -> [Token]
66tokensFromTree (Node o@(TagOpen n _) ts) | n `notElem` nonClosing
67 = [o] <> tokensFromForest ts <> [TagClose n]
68tokensFromTree (Node t [])
69 = [t]
70tokensFromTree _
71 = error "renderTokenTree: leaf node with children."