git.iko.soy/typeable/html-parse
on 9a0971f help sign in
typeable/html-parse/Text/HTML/Parser.hs
244 lines 7.7 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE DeriveGeneric #-}
4module Text.HTML.Parser
5 ( TagName, AttrName, AttrValue
6 , Token(..)
7 , Attr(..)
8 , token
9 , tagStream
10 ) where
12import Data.Char hiding (isSpace)
13import Data.List (unfoldr)
14import GHC.Generics
15import Control.Applicative
16import Data.Monoid
17import Control.Monad (guard)
18import Control.DeepSeq
20import Data.Attoparsec.Text
21import Data.Text (Text)
22import qualified Data.Text as T
23import Data.Text.Lazy.Builder (Builder)
24import qualified Data.Text.Lazy.Builder as B
25import Prelude hiding (take, takeWhile)
27type TagName = Text
28type AttrName = Text
29type AttrValue = Text
31data Token
32 -- | An opening tag. Attribute ordering is arbitrary
33 = TagOpen !TagName [Attr]
34 -- | A closing tag.
35 | TagClose !TagName
36 -- | A text between tags.
37 | ContentChar !Char
38 | ContentText !Text
39 -- | Contents of a comment.
40 | Comment !Builder
41 -- | Doctype
42 | Doctype !Text
43 deriving (Show, Ord, Eq, Generic)
45data Attr = Attr !AttrName !AttrValue
46 deriving (Show, Eq, Ord)
48instance NFData Token where
49 rnf (Comment b) = rnf $ B.toLazyText b
50 rnf _ = ()
52-- | Start in the data state.
53token :: Parser Token
54token = dataState
56-- | 8.2.4.1: Data state
57dataState :: Parser Token
58dataState = do
59 content <- takeWhile (/= '<')
60 if not $ T.null content
61 then return $ ContentText content
62 else char '<' >> tagOpen
64-- | 8.2.4.3: Tag open state
65tagOpen :: Parser Token
66tagOpen =
67 (char '!' >> markupDeclOpen)
68 <|> (char '/' >> endTagOpen)
69 <|> (char '?' >> bogusComment)
70 <|> tryStartTag
71 <|> other
72 where
73 tryStartTag = do
74 c <- peekChar'
75 guard $ isAsciiUpper c || isAsciiLower c
76 tagName
78 other = do
79 return $ ContentChar '<'
81-- | 8.2.4.9: End tag open state
82-- TODO: This isn't right
83endTagOpen :: Parser Token
84endTagOpen = do
85 name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
86 char '>'
87 return $ TagClose name
89-- | 8.2.4.10: Tag name state
90--
91-- deviation: no lower-casing
92tagName :: Parser Token
93tagName = do
94 tag <- takeWhile $ notInClass "\x09\x0a\x0c />"
95 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
96 <|> (char '/' >> selfClosingStartTag tag [])
97 <|> (char '>' >> return (TagOpen tag []))
99-- | 8.2.4.43: Self-closing start tag state
100selfClosingStartTag :: TagName -> [Attr] -> Parser Token
101selfClosingStartTag tag attrs = do
102 (char '>' >> return (TagOpen tag attrs))
103 <|> beforeAttrName tag attrs
105-- | 8.2.4.34: Before attribute name state
106--
107-- deviation: no lower-casing
108beforeAttrName :: TagName -> [Attr] -> Parser Token
109beforeAttrName tag attrs = do
110 skipWhile $ inClass "\x09\x0a\x0c "
111 id $ (char '/' >> selfClosingStartTag tag attrs)
112 <|> (char '>' >> return (TagOpen tag attrs))
113 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
114 <|> attrName tag attrs
116-- | 8.2.4.35: Attribute name state
117attrName :: TagName -> [Attr] -> Parser Token
118attrName tag attrs = do
119 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
120 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
121 <|> (char '/' >> selfClosingStartTag tag attrs)
122 <|> (char '=' >> beforeAttrValue tag attrs name)
123 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
124 -- <|> -- TODO: NULL
126-- | 8.2.4.36: After attribute name state
127afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
128afterAttrName tag attrs name = do
129 skipWhile $ inClass "\x09\x0a\x0c "
130 id $ (char '/' >> selfClosingStartTag tag attrs)
131 <|> (char '=' >> beforeAttrValue tag attrs name)
132 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
133 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
135-- | 8.2.4.37: Before attribute value state
136beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
137beforeAttrValue tag attrs name = do
138 skipWhile $ inClass "\x09\x0a\x0c "
139 id $ (char '"' >> attrValueDQuoted tag attrs name)
140 <|> (char '\'' >> attrValueSQuoted tag attrs name)
141 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
142 <|> attrValueUnquoted tag attrs name
144-- | 8.2.4.38: Attribute value (double-quoted) state
145attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
146attrValueDQuoted tag attrs name = do
147 value <- takeWhile (/= '"')
148 char '"'
149 afterAttrValueQuoted tag attrs name value
151-- | 8.2.4.39: Attribute value (single-quoted) state
152attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
153attrValueSQuoted tag attrs name = do
154 value <- takeWhile (/= '\'')
155 char '\''
156 afterAttrValueQuoted tag attrs name value
158-- | 8.2.4.40: Attribute value (unquoted) state
159attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
160attrValueUnquoted tag attrs name = do
161 value <- takeTill (inClass "\x09\x0a\x0c >")
162 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
163 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
165-- | 8.2.4.42: After attribute value (quoted) state
166afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
167afterAttrValueQuoted tag attrs name value =
168 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
169 <|> (char '/' >> selfClosingStartTag tag attrs')
170 <|> (char '>' >> return (TagOpen tag attrs'))
171 where attrs' = Attr name value : attrs
173-- | 8.2.4.45: Markup declaration open state
174markupDeclOpen :: Parser Token
175markupDeclOpen =
176 try comment
177 <|> try docType
178 -- TODO: Fix the rest
179 where
180 comment = string "--" >> commentStart
181 docType = do
182 s <- take 7
183 guard $ T.toLower s == "doctype"
184 doctype
186-- | 8.2.4.46: Comment start state
187commentStart :: Parser Token
188commentStart = do
189 (char '-' >> commentStartDash)
190 <|> (char '>' >> return (Comment mempty))
192-- | 8.2.4.47: Comment start dash state
193commentStartDash :: Parser Token
194commentStartDash =
195 (char '-' >> commentEnd mempty)
196 <|> (char '>' >> return (Comment mempty))
197 <|> (do c <- anyChar
198 comment (B.singleton '-' <> B.singleton c) )
200-- | 8.2.4.48: Comment state
201comment :: Builder -> Parser Token
202comment content0 = do
203 content <- B.fromText <$> takeWhile (notInClass "-")
204 id $ (char '-' >> commentEndDash (content0 <> content))
205 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
207-- | 8.2.4.49: Comment end dash state
208commentEndDash :: Builder -> Parser Token
209commentEndDash content = do
210 (char '-' >> commentEnd content)
211 <|> (char '\x00' >> comment (content <> "-\xfffd"))
212 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
214-- | 8.2.4.50: Comment end state
215commentEnd :: Builder -> Parser Token
216commentEnd content = do
217 (char '>' >> return (Comment content))
218 <|> (char '\x00' >> comment (content <> "-\xfffd"))
219 -- <|> () TODO: other cases
220 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
222-- | 8.2.4.52: DOCTYPE state
223-- FIXME
224doctype :: Parser Token
225doctype = do
226 content <- takeTill (=='>')
227 char '>'
228 return $ Doctype content
230-- | 8.2.4.44: Bogus comment state
231bogusComment :: Parser Token
232bogusComment = fail "Bogus comment"
234-- | Produce a lazy list of tokens.
235tagStream :: Text -> [Token]
236tagStream = unfoldr f
237 where
238 f :: Text -> Maybe (Token, Text)
239 f t
240 | T.null t = Nothing
241 | otherwise =
242 case parse token t of
243 Done rest tok -> Just (tok, rest)
244 _ -> Nothing