@@ -160,6 +160,7 @@ import Text.HTML.TagSoup.Entity ( lookupEntity )
160160import Data.Default
161161import qualified Data.Set as Set
162162import Control.Monad.Reader
163+import Control.Applicative ((*>), (<*), liftA2)
163164import Data.Monoid
164165
165166type Parser t s = Parsec t s
@@ -332,32 +333,25 @@ romanNumeral upperCase = do
332333
333334-- Parsers for email addresses and URIs
334335
335−emailChar :: Parser [Char] st Char
336−emailChar = alphaNum <|> oneOf "!\"#$%&'*+-/0123456789=?^_{|}~"
337−
338−domain :: Parser [Char] st String
339−domain = do
340− x <- subdomain
341− xs <- many (try $ char '.' >> subdomain)
342− return $ intercalate "." (x:xs)
343−
344−subdomain :: Parser [Char] st String
345−subdomain = many1 (emailChar <|> char '@')
346−
347−emailWord :: Parser [Char] st String
348−emailWord = many1 emailChar -- ignores possibility of quoted strings
349−
350336-- | Parses an email address; returns original and corresponding
351337-- escaped mailto: URI.
352338emailAddress :: Parser [Char] st (String, String)
353−emailAddress = try $ do
354− x <- emailWord
355− xs <- many (try $ char '.' >> emailWord)
356− let addr = intercalate "." (x:xs)
357− char '@'
358− dom <- domain
359− let full = addr ++ '@':dom
360− return (full, escapeURI $ "mailto:" ++ full)
339+emailAddress = try $ liftA2 toResult mailbox (char '@' *> domain)
340+ where toResult mbox dom = let full = mbox ++ '@':dom
341+ in (full, escapeURI $ "mailto:" ++ full)
342+ mailbox = intercalate "." `fmap` (emailWord `sepby1` dot)
343+ domain = intercalate "." `fmap` (subdomain `sepby1` dot)
344+ dot = char '.'
345+ subdomain = many1 $ alphaNum <|> innerPunct
346+ innerPunct = try (satisfy (\c -> isEmailPunct c || c == '@') <*
347+ notFollowedBy space)
348+ emailWord = many1 $ satisfy isEmailChar
349+ isEmailChar c = isAlphaNum c || isEmailPunct c
350+ isEmailPunct c = c `elem` "!\"#$%&'*+-/=?^_{|}~"
351+ -- note: sepBy1 from parsec consumes input when sep
352+ -- succeeds and p fails, so we use this variant here.
353+ sepby1 p sep = liftA2 (:) p (many (try $ sep >> p))
354+
361355
362356-- | Parses a URI. Returns pair of original and URI-escaped version.
363357uri :: Parser [Char] st (String, String)