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