git.iko.soy/typeable/html-parse
on 9f62344 help sign in
typeable/html-parse/Text/HTML/Tree.hs
66 lines 2.3 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ViewPatterns #-}
4module Text.HTML.Tree
5 ( -- * Constructing forests
6 tokensToForest
7 , ParseTokenForestError(..), PStack(..)
8 -- * Deconstructing forests
9 , tokensFromForest
10 , tokensFromTree
11 ) where
13import Data.Monoid
14import Data.Tree
15import Text.HTML.Parser
18tokensToForest :: [Token] -> Either ParseTokenForestError (Forest Token)
19tokensToForest = f (PStack [] [])
20 where
21 f (PStack ss []) [] = Right (reverse ss)
22 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
23 f pstack (t : ts) = case t of
24 TagOpen "br" _ -> f (pushFlatSibling t pstack) ts
25 TagOpen "hr" _ -> f (pushFlatSibling t pstack) ts
26 TagOpen "img" _ -> f (pushFlatSibling t pstack) ts
27 TagOpen _ _ -> f (pushParent t pstack) ts
28 TagClose n -> (`f` ts) =<< popParent n pstack
29 ContentChar _ -> f (pushFlatSibling t pstack) ts
30 ContentText _ -> f (pushFlatSibling t pstack) ts
31 Comment _ -> f (pushFlatSibling t pstack) ts
32 Doctype _ -> f (pushFlatSibling t pstack) ts
34data ParseTokenForestError =
35 ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
36 deriving (Eq, Show)
38data PStack = PStack
39 { _pstackToplevelSiblings :: Forest Token
40 , _pstackParents :: [(Token, Forest Token)]
41 }
42 deriving (Eq, Show)
44pushParent :: Token -> PStack -> PStack
45pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
47popParent :: TagName -> PStack -> Either ParseTokenForestError PStack
48popParent n (PStack ss ((p@(TagOpen n' _), ss') : ps))
49 | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
50popParent n pstack
51 = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
53pushFlatSibling :: Token -> PStack -> PStack
54pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
57tokensFromForest :: Forest Token -> [Token]
58tokensFromForest = mconcat . fmap tokensFromTree
60tokensFromTree :: Tree Token -> [Token]
61tokensFromTree (Node o@(TagOpen n _) ts)
62 = [o] <> tokensFromForest ts <> [TagClose n]
63tokensFromTree (Node t [])
64 = [t]
65tokensFromTree _
66 = error "renderTokenTree: leaf node with children."