git.iko.soy/typeable/html-parse
on dd116a6 help sign in
typeable/html-parse/Text/HTML/Parser.hs
248 lines 7.9 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 hiding (takeWhile)
21import qualified Data.Attoparsec.Text as A
22import Data.Text (Text)
23import qualified Data.Text as T
24import Data.Text.Lazy.Builder (Builder)
25import qualified Data.Text.Lazy.Builder as B
26import Prelude hiding (take, takeWhile)
28type TagName = Text
29type AttrName = Text
30type AttrValue = Text
32data Token
33 -- | An opening tag. Attribute ordering is arbitrary
34 = TagOpen !TagName [Attr]
35 -- | A closing tag.
36 | TagClose !TagName
37 -- | A text between tags.
38 | ContentChar !Char
39 | ContentText !Text
40 -- | Contents of a comment.
41 | Comment !Builder
42 -- | Doctype
43 | Doctype !Text
44 deriving (Show, Ord, Eq, Generic)
46takeWhile = A.takeWhile'
48data Attr = Attr !AttrName !AttrValue
49 deriving (Show, Eq, Ord)
51instance NFData Token where
52 rnf (Comment b) = rnf $ B.toLazyText b
53 rnf _ = ()
55-- | Start in the data state.
56token :: Parser Token
57token = dataState
59-- | 8.2.4.1: Data state
60dataState :: Parser Token
61dataState = do
62 content <- takeWhile (/= '<')
63 if not $ T.null content
64 then return $ ContentText content
65 else char '<' >> tagOpen
67-- | 8.2.4.3: Tag open state
68tagOpen :: Parser Token
69tagOpen =
70 (char '!' >> markupDeclOpen)
71 <|> (char '/' >> endTagOpen)
72 <|> (char '?' >> bogusComment)
73 <|> tryStartTag
74 <|> other
75 where
76 tryStartTag = do
77 c <- peekChar'
78 guard $ isAsciiUpper c || isAsciiLower c
79 tagName
81 other = do
82 return $ ContentChar '<'
84-- | 8.2.4.9: End tag open state
85-- TODO: This isn't right
86endTagOpen :: Parser Token
87endTagOpen = do
88 name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
89 char '>'
90 return $ TagClose name
92-- | 8.2.4.10: Tag name state
93--
94-- deviation: no lower-casing
95tagName :: Parser Token
96tagName = do
97 tag <- takeWhile $ notInClass "\x09\x0a\x0c />"
98 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag [])
99 <|> (char '/' >> selfClosingStartTag tag [])
100 <|> (char '>' >> return (TagOpen tag []))
102-- | 8.2.4.43: Self-closing start tag state
103selfClosingStartTag :: TagName -> [Attr] -> Parser Token
104selfClosingStartTag tag attrs = do
105 (char '>' >> return (TagOpen tag attrs))
106 <|> beforeAttrName tag attrs
108-- | 8.2.4.34: Before attribute name state
109--
110-- deviation: no lower-casing
111beforeAttrName :: TagName -> [Attr] -> Parser Token
112beforeAttrName tag attrs = do
113 skipWhile $ inClass "\x09\x0a\x0c "
114 id $ (char '/' >> selfClosingStartTag tag attrs)
115 <|> (char '>' >> return (TagOpen tag attrs))
116 -- <|> (char '\x00' >> attrName tag attrs) -- TODO: NULL
117 <|> attrName tag attrs
119-- | 8.2.4.35: Attribute name state
120attrName :: TagName -> [Attr] -> Parser Token
121attrName tag attrs = do
122 name <- takeWhile $ notInClass "\x09\x0a\x0c /=>\x00"
123 id $ (satisfy (inClass "\x09\x0a\x0c ") >> afterAttrName tag attrs name)
124 <|> (char '/' >> selfClosingStartTag tag attrs)
125 <|> (char '=' >> beforeAttrValue tag attrs name)
126 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
127 -- <|> -- TODO: NULL
129-- | 8.2.4.36: After attribute name state
130afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
131afterAttrName tag attrs name = do
132 skipWhile $ inClass "\x09\x0a\x0c "
133 id $ (char '/' >> selfClosingStartTag tag attrs)
134 <|> (char '=' >> beforeAttrValue tag attrs name)
135 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
136 <|> attrName tag (Attr name T.empty : attrs) -- not exactly sure this is right
138-- | 8.2.4.37: Before attribute value state
139beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
140beforeAttrValue tag attrs name = do
141 skipWhile $ inClass "\x09\x0a\x0c "
142 id $ (char '"' >> attrValueDQuoted tag attrs name)
143 <|> (char '\'' >> attrValueSQuoted tag attrs name)
144 <|> (char '>' >> return (TagOpen tag (Attr name T.empty : attrs)))
145 <|> attrValueUnquoted tag attrs name
147-- | 8.2.4.38: Attribute value (double-quoted) state
148attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
149attrValueDQuoted tag attrs name = do
150 value <- takeWhile (/= '"')
151 char '"'
152 afterAttrValueQuoted tag attrs name value
154-- | 8.2.4.39: Attribute value (single-quoted) state
155attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
156attrValueSQuoted tag attrs name = do
157 value <- takeWhile (/= '\'')
158 char '\''
159 afterAttrValueQuoted tag attrs name value
161-- | 8.2.4.40: Attribute value (unquoted) state
162attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
163attrValueUnquoted tag attrs name = do
164 value <- takeTill (inClass "\x09\x0a\x0c >")
165 id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
166 <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
168-- | 8.2.4.42: After attribute value (quoted) state
169afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
170afterAttrValueQuoted tag attrs name value =
171 (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
172 <|> (char '/' >> selfClosingStartTag tag attrs')
173 <|> (char '>' >> return (TagOpen tag attrs'))
174 where attrs' = Attr name value : attrs
176-- | 8.2.4.45: Markup declaration open state
177markupDeclOpen :: Parser Token
178markupDeclOpen =
179 try comment
180 <|> try docType
181 -- TODO: Fix the rest
182 where
183 comment = string "--" >> commentStart
184 docType = do
185 -- switching this to asciiCI slowed things down by a factor of two
186 s <- take 7
187 guard $ T.toLower s == "doctype"
188 doctype
190-- | 8.2.4.46: Comment start state
191commentStart :: Parser Token
192commentStart = do
193 (char '-' >> commentStartDash)
194 <|> (char '>' >> return (Comment mempty))
196-- | 8.2.4.47: Comment start dash state
197commentStartDash :: Parser Token
198commentStartDash =
199 (char '-' >> commentEnd mempty)
200 <|> (char '>' >> return (Comment mempty))
201 <|> (do c <- anyChar
202 comment (B.singleton '-' <> B.singleton c) )
204-- | 8.2.4.48: Comment state
205comment :: Builder -> Parser Token
206comment content0 = do
207 content <- B.fromText <$> takeWhile (notInClass "-")
208 id $ (char '-' >> commentEndDash (content0 <> content))
209 <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
211-- | 8.2.4.49: Comment end dash state
212commentEndDash :: Builder -> Parser Token
213commentEndDash content = do
214 (char '-' >> commentEnd content)
215 <|> (char '\x00' >> comment (content <> "-\xfffd"))
216 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
218-- | 8.2.4.50: Comment end state
219commentEnd :: Builder -> Parser Token
220commentEnd content = do
221 (char '>' >> return (Comment content))
222 <|> (char '\x00' >> comment (content <> "-\xfffd"))
223 -- <|> () TODO: other cases
224 <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
226-- | 8.2.4.52: DOCTYPE state
227-- FIXME
228doctype :: Parser Token
229doctype = do
230 content <- takeTill (=='>')
231 char '>'
232 return $ Doctype content
234-- | 8.2.4.44: Bogus comment state
235bogusComment :: Parser Token
236bogusComment = fail "Bogus comment"
238-- | Produce a lazy list of tokens.
239tagStream :: Text -> [Token]
240tagStream = unfoldr f
241 where
242 f :: Text -> Maybe (Token, Text)
243 f t
244 | T.null t = Nothing
245 | otherwise =
246 case parse token t of
247 Done rest tok -> Just (tok, rest)
248 _ -> Nothing