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