@@ -0,0 +1,83 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ViewPatterns #-}
4+
5+module Text.HTML.Tree
6+ ( -- * Class
7+ IsToken(..)
8+ -- * Parsing forests
9+ , parseTokenForest
10+ , ParseTokenForestError(..), PStack(..)
11+ -- * Rendering forests
12+ , renderTokenForest
13+ , renderTokenTree
14+ ) where
15+
16+import Data.Monoid
17+import Data.Tree
18+import Text.HTML.Parser
19+
20+
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''.
24+class IsToken a where
25+ toToken :: a -> Maybe Token
26+ fromToken :: Token -> a
27+
28+instance IsToken Token where
29+ toToken = Just
30+ fromToken = id
31+
32+
33+parseTokenForest :: (IsToken token) => [token] -> Either (ParseTokenForestError token) (Forest token)
34+parseTokenForest = 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
49+
50+data ParseTokenForestError t =
51+ ParseTokenForestErrorBracketMismatch (PStack t) (Maybe Token)
52+ deriving (Eq, Show)
53+
54+data PStack t = PStack
55+ { _pstackToplevelSiblings :: Forest t
56+ , _pstackParents :: [(t, Forest t)]
57+ }
58+ deriving (Eq, Show)
59+
60+pushParent :: t -> PStack t -> PStack t
61+pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
62+
63+popParent :: (IsToken t) => TagName -> PStack t -> Either (ParseTokenForestError t) (PStack t)
64+popParent n (PStack ss ((p@(toToken -> Just (TagOpen n' _)), ss') : ps))
65+ | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
66+popParent n pstack
67+ = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
68+
69+pushFlatSibling :: t -> PStack t -> PStack t
70+pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
71+
72+
73+renderTokenForest :: (IsToken t, Show t) => Forest t -> [t]
74+renderTokenForest = mconcat . fmap renderTokenTree
75+
76+renderTokenTree :: (IsToken t, Show t) => Tree t -> [t]
77+renderTokenTree = \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: " <> show bad