git.iko.soy/typeable/html-parse
on master help sign in
Abandon IsToken generalisation.
6658bf8Matthias Fischmann
Text/HTML/Tree.hs+27−42
compare with master
unifiedsplit
@@ -2,12 +2,10 @@
2{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE ViewPatterns #-}
3
3
4module Text.HTML.Tree
4module Text.HTML.Tree
5− ( -- * Class
6− IsToken(..)
7− -- * Parsing forests
5+ ( -- * Constructing forests
8− , tokensToForest
6+ tokensToForest
9 , ParseTokenForestError(..), PStack(..)
7 , ParseTokenForestError(..), PStack(..)
10− -- * Rendering forests
8+ -- * Deconstructing forests
11 , tokensFromForest
9 , tokensFromForest
12 , tokensFromTree
10 , tokensFromTree
13 ) where
11 ) where
@@ -17,64 +15,51 @@ import Data.Tree
17import Text.HTML.Parser
15import Text.HTML.Parser
18
16
19
17
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'.
23−class IsToken a where
24− toToken :: a -> Maybe Token
25− fromToken :: Token -> a
26−
27−instance IsToken Token where
28− toToken = Just
29− fromToken = id
30−
31−
32−tokensToForest :: (IsToken token) => [token] -> Either (ParseTokenForestError token) (Forest token)
18+tokensToForest :: [Token] -> Either ParseTokenForestError (Forest Token)
33tokensToForest = f (PStack [] [])
19tokensToForest = f (PStack [] [])
34 where
20 where
35 f (PStack ss []) [] = Right (reverse ss)
21 f (PStack ss []) [] = Right (reverse ss)
36 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
22 f pstack [] = Left $ ParseTokenForestErrorBracketMismatch pstack Nothing
37− f pstack (t : ts) = case toToken t of
23+ f pstack (t : ts) = case t of
38− Just (TagOpen "br" _) -> f (pushFlatSibling t pstack) ts
24+ TagOpen "br" _ -> f (pushFlatSibling t pstack) ts
39− Just (TagOpen "hr" _) -> f (pushFlatSibling t pstack) ts
25+ TagOpen "hr" _ -> f (pushFlatSibling t pstack) ts
40− Just (TagOpen "img" _) -> f (pushFlatSibling t pstack) ts
26+ TagOpen "img" _ -> f (pushFlatSibling t pstack) ts
41− Just (TagOpen _ _) -> f (pushParent t pstack) ts
27+ TagOpen _ _ -> f (pushParent t pstack) ts
42− Just (TagClose n) -> (`f` ts) =<< popParent n pstack
28+ TagClose n -> (`f` ts) =<< popParent n pstack
43− Just (ContentChar _) -> f (pushFlatSibling t pstack) ts
29+ ContentChar _ -> f (pushFlatSibling t pstack) ts
44− Just (ContentText _) -> f (pushFlatSibling t pstack) ts
30+ ContentText _ -> f (pushFlatSibling t pstack) ts
45− Just (Comment _) -> f (pushFlatSibling t pstack) ts
31+ Comment _ -> f (pushFlatSibling t pstack) ts
46− Just (Doctype _) -> f (pushFlatSibling t pstack) ts
47− Nothing -> f (pushFlatSibling t pstack) ts
32+ Doctype _ -> f (pushFlatSibling t pstack) ts
48
33
49−data ParseTokenForestError t =
34+data ParseTokenForestError =
50− ParseTokenForestErrorBracketMismatch (PStack t) (Maybe Token)
35+ ParseTokenForestErrorBracketMismatch PStack (Maybe Token)
51 deriving (Eq, Show)
36 deriving (Eq, Show)
52
37
53−data PStack t = PStack
38+data PStack = PStack
54− { _pstackToplevelSiblings :: Forest t
39+ { _pstackToplevelSiblings :: Forest Token
55− , _pstackParents :: [(t, Forest t)]
40+ , _pstackParents :: [(Token, Forest Token)]
56 }
41 }
57 deriving (Eq, Show)
42 deriving (Eq, Show)
58
43
59−pushParent :: t -> PStack t -> PStack t
44+pushParent :: Token -> PStack -> PStack
60pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
45pushParent t (PStack ss ps) = PStack [] ((t, ss) : ps)
61
46
62−popParent :: (IsToken t) => TagName -> PStack t -> Either (ParseTokenForestError t) (PStack t)
47+popParent :: TagName -> PStack -> Either ParseTokenForestError PStack
63−popParent n (PStack ss ((p@(toToken -> Just (TagOpen n' _)), ss') : ps))
48+popParent n (PStack ss ((p@(TagOpen n' _), ss') : ps))
64 | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
49 | n == n' = Right $ PStack (Node p (reverse ss) : ss') ps
65popParent n pstack
50popParent n pstack
66 = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
51 = Left $ ParseTokenForestErrorBracketMismatch pstack (Just $ TagClose n)
67
52
68−pushFlatSibling :: t -> PStack t -> PStack t
53+pushFlatSibling :: Token -> PStack -> PStack
69pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
54pushFlatSibling t (PStack ss ps) = PStack (Node t [] : ss) ps
70
55
71
56
72−tokensFromForest :: (IsToken t) => Forest t -> [t]
57+tokensFromForest :: Forest Token -> [Token]
73tokensFromForest = mconcat . fmap tokensFromTree
58tokensFromForest = mconcat . fmap tokensFromTree
74
59
75−tokensFromTree :: (IsToken t) => Tree t -> [t]
60+tokensFromTree :: Tree Token -> [Token]
76−tokensFromTree (Node o@(toToken -> Just (TagOpen n _)) ts)
61+tokensFromTree (Node o@(TagOpen n _) ts)
77− = [o] <> tokensFromForest ts <> [fromToken $ TagClose n]
62+ = [o] <> tokensFromForest ts <> [TagClose n]
78tokensFromTree (Node t [])
63tokensFromTree (Node t [])
79 = [t]
64 = [t]
80tokensFromTree _
65tokensFromTree _