Skip to content
This repository
Browse code

Detect leaf nodes while making the HTML tree

  • Loading branch information...
commit c06051b0000236874f06d09c9b3bda034db6275f 1 parent e61eeee
Jasper Van der Jeugt authored

Showing 1 changed file with 16 additions and 11 deletions. Show diff stats Hide diff stats

  1. +16 11 Util/BlazeFromHtml.hs
27 Util/BlazeFromHtml.hs
@@ -15,7 +15,7 @@ import System.Console.GetOpt
15 15 import Text.HTML.TagSoup
16 16
17 17 import Util.Sanitize (sanitize)
18   -import Util.GenerateHtmlCombinators
  18 +import Util.GenerateHtmlCombinators hiding (main)
19 19
20 20 -- | Simple type to represent attributes.
21 21 --
@@ -41,18 +41,22 @@ data CombinatorType = ParentCombinator
41 41 -- | Traverse the list of tags to produce an intermediate representation of the
42 42 -- HTML tree.
43 43 --
44   -makeTree :: Bool -- ^ Should ignore errors
  44 +makeTree :: HtmlVariant -- ^ HTML variant used
  45 + -> Bool -- ^ Should ignore errors
45 46 -> [String] -- ^ Stack of open tags
46 47 -> [Tag String] -- ^ Tags to parse
47 48 -> (Html, [Tag String]) -- ^ (Result, unparsed part)
48   -makeTree ignore stack []
  49 +makeTree _ ignore stack []
49 50 | null stack || ignore = (Block [], [])
50 51 | otherwise = error $ "Error: tags left open at the end: " ++ show stack
51   -makeTree ignore stack (TagPosition row _ : x : xs) = case x of
  52 +makeTree variant ignore stack (TagPosition row _ : x : xs) = case x of
52 53 TagOpen tag attrs -> if toLower' tag == "!doctype"
53 54 then addHtml Doctype xs
54   - else let (inner, t) = makeTree ignore (tag : stack) xs
55   - p = Parent (toLower' tag) (map (first toLower') attrs) inner
  55 + else let tag' = toLower' tag
  56 + (inner, t) = case combinatorType variant tag' of
  57 + LeafCombinator -> (Block [], xs)
  58 + _ -> makeTree variant ignore (tag' : stack) xs
  59 + p = Parent tag' (map (first toLower') attrs) inner
56 60 in addHtml p t
57 61 -- The closing tag must match the stack.
58 62 TagClose tag -> if listToMaybe stack == Just (toLower' tag) || ignore
@@ -61,13 +65,13 @@ makeTree ignore stack (TagPosition row _ : x : xs) = case x of
61 65 ++ show stack ++ " should be closed instead."
62 66 TagText text -> addHtml (Text text) xs
63 67 TagComment comment -> addHtml (Comment comment) xs
64   - _ -> makeTree ignore stack xs
  68 + _ -> makeTree variant ignore stack xs
65 69 where
66   - addHtml html xs' = let (Block l, r) = makeTree ignore stack xs'
  70 + addHtml html xs' = let (Block l, r) = makeTree variant ignore stack xs'
67 71 in (Block (html : l), r)
68 72
69 73 toLower' = map toLower
70   -makeTree _ _ _ = error "TagSoup error"
  74 +makeTree _ _ _ _ = error "TagSoup error"
71 75
72 76 -- | Remove empty text from the HTML.
73 77 --
@@ -199,8 +203,9 @@ blazeFromHtml :: HtmlVariant -- ^ Variant to use
199 203 -> String -- ^ HTML code
200 204 -> String -- ^ Resulting code
201 205 blazeFromHtml variant standalone ignore name =
202   - unlines . addSignature . fromHtml variant ignore . joinHtmlDoctype
203   - . minimizeBlocks . removeEmptyText . fst . makeTree ignore []
  206 + unlines . addSignature . fromHtml variant ignore
  207 + . joinHtmlDoctype . minimizeBlocks
  208 + . removeEmptyText . fst . makeTree variant ignore []
204 209 . parseTagsOptions parseOptions { optTagPosition = True }
205 210 where
206 211 addSignature body = if standalone then [ name ++ " :: Html"

0 comments on commit c06051b

Please sign in to comment.
Something went wrong with that request. Please try again.