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