git.iko.soy/typeable/html-parse
on master help sign in
typeable/html-parse/src/Text/HTML/Tree.hs
91 lines 3.7 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 Prelude
19import Text.HTML.Parser
21-- | construct a 'Forest' from a 'Token' list.
22--
23-- This code correctly handles void elements. Void elements are required to have a start tag and must not have an end tag. See 'nonClosing'.
24--
25-- This code does __not__ correctly handle optional tags. It assumes all optional start and end tags are present.
26--
27-- <https:\/\/www.w3.org\/TR\/html52\/syntax.html#optional-tags>
28tokensToForest :: [Token] -> Either ParseTokenForestError (Forest Token)
29tokensToForest = f (PStack [] [])
30 where
31 f (PStack ss []) [] = Right (reverse ss)
32 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
33 f pstack (t : ts) = case t of
34 TagOpen n _ -> if n `elem` nonClosing
35 then f (pushFlatSibling t pstack) ts
36 else f (pushParent t pstack) ts
37 TagSelfClose {} -> f (pushFlatSibling t pstack) ts
38 TagClose n -> (`f` ts) =<< popParent n pstack
39 ContentChar _ -> f (pushFlatSibling t pstack) ts
40 ContentText _ -> f (pushFlatSibling t pstack) ts
41 Comment _ -> f (pushFlatSibling t pstack) ts
42 Doctype _ -> f (pushFlatSibling t pstack) ts
44-- | void elements which must not have an end tag
45--
46-- This list does not include the obsolete @\<command\>@ and @\<keygen\>@ elements.
47--
48-- @ nonClosing = ["br", "hr", "img", "meta", "area", "base", "col", "embed", "input", "link", "param", "source", "track", "wbr"] @
49--
50-- <https:\/\/www.w3.org\/TR\/html52\/syntax.html#void-elements>
51nonClosing :: [Text]
52nonClosing = ["br", "hr", "img", "meta", "area", "base", "col", "embed", "input", "link", "param", "source", "track", "wbr"]
54data ParseTokenForestError =
55 ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
56 deriving (Eq, Show)
58data PStack = PStack
59 { _pstackToplevelSiblings :: Forest Token
60 , _pstackParents :: [(Token, Forest Token)]
61 }
62 deriving (Eq, Show)
64pushParent :: Token -> PStack -> PStack
65pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
67popParent :: TagName -> PStack -> Either ParseTokenForestError PStack
68popParent n (PStack ss ((p@(TagOpen n' _), ss') : ps))
69 | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
70popParent n pstack
71 = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
73pushFlatSibling :: Token -> PStack -> PStack
74pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
76-- | convert a 'Forest' of 'Token' into a list of 'Token'.
77--
78-- This code correctly handles void elements. Void elements are required to have a start tag and must not have an end tag. See 'nonClosing'.
79tokensFromForest :: Forest Token -> [Token]
80tokensFromForest = mconcat . fmap tokensFromTree
82-- | convert a 'Tree' of 'Token' into a list of 'Token'.
83--
84-- This code correctly handles void elements. Void elements are required to have a start tag and must not have an end tag. See 'nonClosing'.
85tokensFromTree :: Tree Token -> [Token]
86tokensFromTree (Node o@(TagOpen n _) ts) | n `notElem` nonClosing
87 = [o] <> tokensFromForest ts <> [TagClose n]
88tokensFromTree (Node t [])
89 = [t]
90tokensFromTree _
91 = error "renderTokenTree: leaf node with children."