git.iko.soy/typeable/html-parse
on 2e97d8a help sign in
typeable/html-parse/Text/HTML/Tree.hs
81 lines 2.9 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ViewPatterns #-}
4module Text.HTML.Tree
5 ( -- * Class
6 IsToken(..)
7 -- * Parsing forests
8 , tokensToForest
9 , ParseTokenForestError(..), PStack(..)
10 -- * Rendering forests
11 , tokensFromForest
12 , tokensFromTree
13 ) where
15import Data.Monoid
16import Data.Tree
17import Text.HTML.Parser
20-- | If you want to store additional data into your tree, you can define your own token type and
21-- instantiate this class to define a mapping between your type and 'Token'. See
22-- 'parseTokenForest'.
23class IsToken a where
24 toToken :: a -> Maybe Token
25 fromToken :: Token -> a
27instance IsToken Token where
28 toToken = Just
29 fromToken = id
32tokensToForest :: (IsToken token) => [token] -> Either (ParseTokenForestError token) (Forest token)
33tokensToForest = f (PStack [] [])
34 where
35 f (PStack ss []) [] = Right (reverse ss)
36 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
37 f pstack (t : ts) = case toToken t of
38 Just (TagOpen "br" _) -> f (pushFlatSibling t pstack) ts
39 Just (TagOpen "hr" _) -> f (pushFlatSibling t pstack) ts
40 Just (TagOpen "img" _) -> f (pushFlatSibling t pstack) ts
41 Just (TagOpen _ _) -> f (pushParent t pstack) ts
42 Just (TagClose n) -> (`f` ts) =<< popParent n pstack
43 Just (ContentChar _) -> f (pushFlatSibling t pstack) ts
44 Just (ContentText _) -> f (pushFlatSibling t pstack) ts
45 Just (Comment _) -> f (pushFlatSibling t pstack) ts
46 Just (Doctype _) -> f (pushFlatSibling t pstack) ts
47 Nothing -> f (pushFlatSibling t pstack) ts
49data ParseTokenForestError t =
50 ParseTokenForestErrorBracketMismatch (PStack t) (Maybe Token)
51 deriving (Eq, Show)
53data PStack t = PStack
54 { _pstackToplevelSiblings :: Forest t
55 , _pstackParents :: [(t, Forest t)]
56 }
57 deriving (Eq, Show)
59pushParent :: t -> PStack t -> PStack t
60pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
62popParent :: (IsToken t) => TagName -> PStack t -> Either (ParseTokenForestError t) (PStack t)
63popParent n (PStack ss ((p@(toToken -> Just (TagOpen n' _)), ss') : ps))
64 | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
65popParent n pstack
66 = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
68pushFlatSibling :: t -> PStack t -> PStack t
69pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
72renderTokenForest :: (IsToken t) => Forest t -> [t]
73renderTokenForest = mconcat . fmap renderTokenTree
75renderTokenTree :: (IsToken t) => Tree t -> [t]
76renderTokenTree (Node o@(toToken -> Just (TagOpen n _)) ts)
77 = [o] <> renderTokenForest ts <> [fromToken $ TagClose n]
78renderTokenTree (Node t []) =
79 = [t]
80renderTokenTree _
81 = error "renderTokenTree: leaf node with children."