@@ -0,0 +1,240 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+
4+module Parser
5+ ( Token(..)
6+ , Attr(..)
7+ , token
8+ , tagStream
9+ ) where
10+
11+import Data.Char hiding (isSpace)
12+import Data.List (unfoldr)
13+import GHC.Generics
14+import Control.Applicative
15+import Data.Monoid
16+import Control.Monad (guard)
17+import Control.DeepSeq
18+
19+import Data.Attoparsec.Text
20+import Data.Text (Text)
21+import qualified Data.Text as T
22+import Data.Text.Lazy.Builder (Builder)
23+import qualified Data.Text.Lazy.Builder as B
24+import Prelude hiding (take, takeWhile)
25+
26+type TagName = Text
27+type AttrName = Text
28+type AttrValue = Text
29+
30+data 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)
45+
46+data Attr = Attr !AttrName !AttrValue
47+ deriving (Show, Eq, Ord)
48+
49+instance NFData Token where
50+ rnf (Comment b) = rnf $ B.toLazyText b
51+ rnf _ = ()
52+
53+-- | Start in the data state.
54+token :: Parser Token
55+token = dataState
56+
57+-- | 8.2.4.1: Data state
58+dataState :: Parser Token
59+dataState = do
60+ content <- takeWhile (/= '<')
61+ if not $ T.null content
62+ then return $ ContentText content
63+ else char '<' >> tagOpen
64+
65+-- | 8.2.4.3: Tag open state
66+tagOpen :: Parser Token
67+tagOpen =
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
78+
79+ other = do
80+ return $ ContentChar '<'
81+
82+-- | 8.2.4.9: End tag open state
83+-- TODO: This isn't right
84+endTagOpen :: Parser Token
85+endTagOpen = do
86+ name <- takeWhile $ \c -> isAsciiUpper c || isAsciiLower c
87+ char '>'
88+ return $ TagClose name
89+
90+-- | 8.2.4.10: Tag name state
91+--
92+-- deviation: no lower-casing
93+tagName :: Parser Token
94+tagName = 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 []))
99+
100+-- | 8.2.4.43: Self-closing start tag state
101+selfClosingStartTag :: TagName -> [Attr] -> Parser Token
102+selfClosingStartTag tag attrs = do
103+ (char '>' >> return (TagOpen tag attrs))
104+ <|> beforeAttrName tag attrs
105+
106+-- | 8.2.4.34: Before attribute name state
107+--
108+-- deviation: no lower-casing
109+beforeAttrName :: TagName -> [Attr] -> Parser Token
110+beforeAttrName 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
116+
117+-- | 8.2.4.35: Attribute name state
118+attrName :: TagName -> [Attr] -> Parser Token
119+attrName 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
126+
127+-- | 8.2.4.36: After attribute name state
128+afterAttrName :: TagName -> [Attr] -> AttrName -> Parser Token
129+afterAttrName 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
135+
136+-- | 8.2.4.37: Before attribute value state
137+beforeAttrValue :: TagName -> [Attr] -> AttrName -> Parser Token
138+beforeAttrValue 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
144+
145+-- | 8.2.4.38: Attribute value (double-quoted) state
146+attrValueDQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
147+attrValueDQuoted tag attrs name = do
148+ value <- takeTill (/= '"')
149+ afterAttrValueQuoted tag attrs name value
150+
151+-- | 8.2.4.39: Attribute value (single-quoted) state
152+attrValueSQuoted :: TagName -> [Attr] -> AttrName -> Parser Token
153+attrValueSQuoted tag attrs name = do
154+ value <- takeTill (/= '\'')
155+ afterAttrValueQuoted tag attrs name value
156+
157+-- | 8.2.4.40: Attribute value (unquoted) state
158+attrValueUnquoted :: TagName -> [Attr] -> AttrName -> Parser Token
159+attrValueUnquoted tag attrs name = do
160+ value <- takeTill (inClass "\x09\x0a\x0c >")
161+ id $ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs) -- unsure: don't emit?
162+ <|> (char '>' >> return (TagOpen tag (Attr name value : attrs)))
163+
164+-- | 8.2.4.42: After attribute value (quoted) state
165+afterAttrValueQuoted :: TagName -> [Attr] -> AttrName -> AttrValue -> Parser Token
166+afterAttrValueQuoted tag attrs name value =
167+ (satisfy (inClass "\x09\x0a\x0c ") >> beforeAttrName tag attrs')
168+ <|> (char '/' >> selfClosingStartTag tag attrs')
169+ <|> (char '>' >> return (TagOpen name attrs'))
170+ where attrs' = Attr name value : attrs
171+
172+-- | 8.2.4.45: Markup declaration open state
173+markupDeclOpen :: Parser Token
174+markupDeclOpen =
175+ try comment
176+ <|> try docType
177+ -- TODO: Fix the rest
178+ where
179+ comment = string "--" >> commentStart
180+ docType = do
181+ s <- take 7
182+ guard $ T.toLower s == "doctype"
183+ doctype
184+
185+-- | 8.2.4.46: Comment start state
186+commentStart :: Parser Token
187+commentStart = do
188+ (char '-' >> commentStartDash)
189+ <|> (char '>' >> return (Comment mempty))
190+
191+-- | 8.2.4.47: Comment start dash state
192+commentStartDash :: Parser Token
193+commentStartDash =
194+ (char '-' >> commentEnd mempty)
195+ <|> (char '>' >> return (Comment mempty))
196+ <|> (do c <- anyChar
197+ comment (B.singleton '-' <> B.singleton c) )
198+
199+-- | 8.2.4.48: Comment state
200+comment :: Builder -> Parser Token
201+comment content0 = do
202+ content <- B.fromText <$> takeWhile (notInClass "-")
203+ id $ (char '-' >> commentEndDash (content0 <> content))
204+ <|> (char '\x00' >> comment (content0 <> content <> B.singleton '\xfffd'))
205+
206+-- | 8.2.4.49: Comment end dash state
207+commentEndDash :: Builder -> Parser Token
208+commentEndDash content = do
209+ (char '-' >> commentEnd content)
210+ <|> (char '\x00' >> comment (content <> "-\xfffd"))
211+ <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
212+
213+-- | 8.2.4.50: Comment end state
214+commentEnd :: Builder -> Parser Token
215+commentEnd content = do
216+ (char '>' >> return (Comment content))
217+ <|> (char '\x00' >> comment (content <> "-\xfffd"))
218+ -- <|> () TODO: other cases
219+ <|> (anyChar >>= \c -> comment (content <> "-" <> B.singleton c))
220+
221+-- | 8.2.4.52: DOCTYPE state
222+-- FIXME
223+doctype :: Parser Token
224+doctype = Doctype <$> takeTill (=='>')
225+
226+-- | 8.2.4.44: Bogus comment state
227+bogusComment :: Parser Token
228+bogusComment = fail "Bogus comment"
229+
230+-- | Produce a lazy list of tokens.
231+tagStream :: Text -> [Token]
232+tagStream = unfoldr f
233+ where
234+ f :: Text -> Maybe (Token, Text)
235+ f t
236+ | T.null t = Nothing
237+ | otherwise =
238+ case parse token t of
239+ Done rest tok -> Just (tok, rest)
240+ _ -> Nothing