diff --git a/Text/ParserCombinators/Parsec/Rfc2234.hs b/Text/ParserCombinators/Parsec/Rfc2234.hs --- a/Text/ParserCombinators/Parsec/Rfc2234.hs +++ b/Text/ParserCombinators/Parsec/Rfc2234.hs @@ -48,7 +48,7 @@ | n < 0 = return [] | n > m = return [] | n == m = count n p - | n == 0 = do foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) + | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) -- |Helper function to generate 'Parser'-based instances for @@ -164,7 +164,7 @@ -- LF) may be quoted. quoted_pair :: CharParser st String -quoted_pair = do char '\\' +quoted_pair = do _ <- char '\\' r <- noneOf "\r\n" return ['\\',r] "quoted pair" @@ -174,11 +174,11 @@ -- LF are not allowed at all. quoted_string :: CharParser st String -quoted_string = do dquote +quoted_string = do _ <- dquote r <- many qcont - dquote + _ <- dquote return ("\"" ++ concat r ++ "\"") "quoted string" where qtext = noneOf "\\\"\r\n" - qcont = (many1 qtext) <|> (quoted_pair) + qcont = many1 qtext <|> quoted_pair diff --git a/Text/ParserCombinators/Parsec/Rfc2821.hs b/Text/ParserCombinators/Parsec/Rfc2821.hs --- a/Text/ParserCombinators/Parsec/Rfc2821.hs +++ b/Text/ParserCombinators/Parsec/Rfc2821.hs @@ -17,8 +17,7 @@ import Control.Exception ( assert ) import Control.Monad.State import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Error -import Data.List ( intersperse ) +import Data.List ( intercalate ) import Data.Char ( toLower ) import Text.ParserCombinators.Parsec.Rfc2234 @@ -83,8 +82,8 @@ handleSmtpCmd cmd = get >>= \st -> match st cmd where match :: SessionState -> SmtpCmd -> SmtpdFSM - match HaveQuit _ = assert (False) (event Shutdown) - match HaveData _ = assert (False) (trans (HaveData, StartData)) + match HaveQuit _ = assert False (event Shutdown) + match HaveData _ = assert False (trans (HaveData, StartData)) match _ (WrongArg c _) = event (SyntaxErrorIn c) match _ Quit = trans (HaveQuit, Shutdown) match _ Noop = event SayOK @@ -186,7 +185,7 @@ data Mailbox = Mailbox [String] String String instance Eq Mailbox where - lhs == rhs = (norm lhs) == (norm rhs) + lhs == rhs = norm lhs == norm rhs where norm (Mailbox rt lp hp) = (rt, lp, map toLower hp) @@ -194,7 +193,7 @@ show (Mailbox [] [] []) = "<>" show (Mailbox [] "postmaster" []) = "" show (Mailbox p u d) = let - route = concat . (intersperse ",") . (map ((:) '@')) $ p + route = intercalate "," . map ((:) '@') $ p mbox = u ++ "@" ++ d in if null route then "<" ++ mbox ++ ">" else "<" ++ route ++ ":" ++ mbox ++ ">" @@ -395,7 +394,7 @@ where p = do r1 <- local_part - char '@' + _ <- char '@' r2 <- domain return (Mailbox [] r1 r2) @@ -438,7 +437,7 @@ where p = do r <- many1 (alpha <|> digit <|> char '-') - if (last r == '-') + if last r == '-' then fail "subdomain must not end with hyphen" else return r @@ -464,7 +463,7 @@ -- or a 'quoted_string'. word :: CharParser st String -word = (atom <|> (quoted_string >>= return . show)) +word = (atom <|> fmap show quoted_string) "word or quoted-string" @@ -491,7 +490,7 @@ mkCmd0 :: String -> a -> CharParser st a mkCmd0 str cons = (do try (caseString str) - skipMany wsp >> crlf + _ <- skipMany wsp >> crlf return cons) str -- |Construct a parser for a command with an argument, which @@ -503,11 +502,11 @@ -> CharParser st SmtpCmd mkCmd1 str cons p = do try (caseString str) - wsp + _ <- wsp input <- getInput st <- getState let eol = skipMany wsp >> crlf - p' = (between (many wsp) eol p) str + p' = between (many wsp) eol p str r = runParser p' st "" input case r of Left e -> return (WrongArg str e) @@ -519,6 +518,4 @@ tokenList :: CharParser st String -> Char -> CharParser st String -tokenList p c = do - xs <- sepBy1 p (char c) - return (concat (intersperse [c] xs)) +tokenList p c = fmap (intercalate [c]) (sepBy1 p (char c)) diff --git a/Text/ParserCombinators/Parsec/Rfc2822.hs b/Text/ParserCombinators/Parsec/Rfc2822.hs --- a/Text/ParserCombinators/Parsec/Rfc2822.hs +++ b/Text/ParserCombinators/Parsec/Rfc2822.hs @@ -18,7 +18,7 @@ import System.Time import Data.Char ( ord ) -import Data.List ( intersperse ) +import Data.List ( intercalate ) import Control.Monad ( liftM ) import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Rfc2234 hiding ( quoted_pair, quoted_string ) @@ -80,7 +80,7 @@ -- backslash and the actual content. quoted_pair :: CharParser a String -quoted_pair = do { char '\\'; r <- text; return ['\\',r] } +quoted_pair = do { _ <- char '\\'; r <- text; return ['\\',r] } "quoted pair" @@ -113,10 +113,10 @@ -- 'quoted_pair's, and 'fws' between brackets. Comments may nest. comment :: CharParser a String -comment = do char '(' +comment = do _ <- char '(' r1 <- many ccontent r2 <- option [] fws - char ')' + _ <- char ')' return ("(" ++ concat r1 ++ r2 ++ ")") "comment" where @@ -153,8 +153,7 @@ -- |Match two or more 'atext's interspersed by dots. dot_atom_text :: CharParser a String -dot_atom_text = do r <- sepBy1 (many1 atext) (char '.') - return (concat (intersperse "." r)) +dot_atom_text = fmap (intercalate ".") (sepBy1 (many1 atext) (char '.')) "dot atom content" @@ -177,12 +176,12 @@ -- preceeding or following the \"atom\" is skipped automatically. quoted_string :: CharParser a String -quoted_string = unfold (do dquote +quoted_string = unfold (do _ <- dquote r1 <- many (do r1 <- option [] fws r2 <- qcontent return (r1 ++ r2)) r2 <- option [] fws - dquote + _ <- dquote return ("\"" ++ concat r1 ++ r2 ++ "\"")) "quoted string" @@ -214,9 +213,9 @@ unstructured :: CharParser a String unstructured = do r1 <- option [] fws - r2 <- many (do r1 <- utext - r2 <- option [] fws - return (r1 : r2)) + r2 <- many (do r3 <- utext + r4 <- option [] fws + return (r3 : r4)) return (r1 ++ concat r2) "unstructured text" @@ -252,10 +251,10 @@ date_time :: CharParser a CalendarTime date_time = do wd <- option Monday (try (do wd <- day_of_week - char ',' + _ <- char ',' return wd)) (y,m,d) <- date - fws + _ <- fws (td,z) <- time optional cfws return (CalendarTime y m d (tdHour td) (tdMin td) (tdSec td) 0 wd 0 "" z False) @@ -339,7 +338,7 @@ time :: CharParser a (TimeDiff,Int) time = do t <- time_of_day - fws + _ <- fws z <- zone return (t,z) "time and zone specification" @@ -349,9 +348,9 @@ time_of_day :: CharParser a TimeDiff time_of_day = do h <- hour - char ':' + _ <- char ':' m <- minute - s <- option 0 (do { char ':'; second } ) + s <- option 0 (do { _ <- char ':'; second } ) return (TimeDiff 0 0 0 h m s 0) "time specification" @@ -384,11 +383,11 @@ -- seconds as an integer. 'obs_zone' is matched as well. zone :: CharParser a Int -zone = ( do char '+' +zone = ( do _ <- char '+' h <- hour m <- minute return (((h*60)+m)*60) - <|> do char '-' + <|> do _ <- char '-' h <- hour m <- minute return (-((h*60)+m)*60) @@ -418,7 +417,7 @@ -- address. mailbox :: CharParser a NameAddr -mailbox = try name_addr <|> (addr_spec >>= return . NameAddr Nothing) +mailbox = try name_addr <|> fmap (NameAddr Nothing) addr_spec "mailbox" -- |Parse an 'angle_addr', optionally prefaced with a 'display_name', @@ -433,9 +432,9 @@ -- |Parse an 'angle_addr' or an 'obs_angle_addr' and return the address. angle_addr :: CharParser a String -angle_addr = try (unfold (do char '<' +angle_addr = try (unfold (do _ <- char '<' r <- addr_spec - char '>' + _ <- char '>' return r) "angle address" ) @@ -453,17 +452,17 @@ -- > Right ["user1@example.org","user2@example.org"] group :: CharParser a [NameAddr] -group = do display_name - char ':' +group = do _ <- display_name + _ <- char ':' r <- option [] mailbox_list - unfold $ char ';' + _ <- unfold $ char ';' return r "address group" -- |Parse and return a 'phrase'. display_name :: CharParser a String -display_name = phrase >>= return . concat . intersperse " " +display_name = fmap unwords phrase "display name" -- |Parse a list of 'mailbox' addresses, every two addresses being @@ -488,7 +487,7 @@ addr_spec :: CharParser a String addr_spec = do r1 <- local_part - char '@' + _ <- char '@' r2 <- domain return (r1 ++ "@" ++ r2) "address specification" @@ -512,10 +511,10 @@ -- character. The complete string is returned verbatim. domain_literal :: CharParser a String -domain_literal = unfold (do char '[' +domain_literal = unfold (do _ <- char '[' r <- many $ do { optional fws; dcontent } optional fws - char ']' + _ <- char ']' return ("[" ++ concat r ++ "]")) "domain literal" @@ -563,9 +562,7 @@ message :: CharParser a Message message = do f <- fields - b <- option [] (do crlf - b <- body - return b) + b <- option [] (do _ <- crlf; body) return (Message f b) -- |This parser will return a message body as specified by this RFC; @@ -728,11 +725,11 @@ -- and whitespace. msg_id :: CharParser a String -msg_id = unfold (do char '<' +msg_id = unfold (do _ <- char '<' idl <- id_left - char '@' + _ <- char '@' idr <- id_right - char '>' + _ <- char '>' return ("<" ++ idl ++ "@" ++ idr ++ ">")) "message ID" @@ -757,9 +754,9 @@ -- 'msg_id'. no_fold_quote :: CharParser a String -no_fold_quote = do dquote +no_fold_quote = do _ <- dquote r <- many (many1 qtext <|> quoted_pair) - dquote + _ <- dquote return ("\"" ++ concat r ++ "\"") "non-folding quoted string" @@ -768,10 +765,9 @@ -- 'msg_id'. no_fold_literal :: CharParser a String -no_fold_literal = do char '[' +no_fold_literal = do _ <- char '[' r <- many (many1 dtext <|> quoted_pair) - char ']' - return ("\"" ++ concat r ++ "\"") + _ <- char ']' return ("[" ++ concat r ++ "]") "non-folding domain literal" @@ -794,9 +790,7 @@ keywords :: CharParser a [[String]] keywords = header "Keywords" (do r1 <- phrase - r2 <- many (do char ',' - r <- phrase - return r) + r2 <- many (do _ <- char ','; phrase) return (r1:r2)) @@ -857,9 +851,9 @@ return_path = header "Return-Path:" path path :: CharParser a String -path = unfold ( do char '<' - r <- choice [ try addr_spec, do { cfws; return [] } ] - char '>' +path = unfold ( do _ <- char '<' + r <- choice [ try addr_spec, do { _ <- cfws; return [] } ] + _ <- char '>' return ("<" ++ r ++ ">") <|> obs_path ) @@ -867,7 +861,7 @@ received :: CharParser a ([(String,String)], CalendarTime) received = header "Received" (do r1 <- name_val_list - char ';' + _ <- char ';' r2 <- date_time return (r1,r2)) @@ -878,7 +872,7 @@ name_val_pair :: CharParser a (String,String) name_val_pair = do r1 <- item_name - cfws + _ <- cfws r2 <- item_value return (r1,r2) "a name/value pair" @@ -906,9 +900,9 @@ optional_field :: CharParser a (String,String) optional_field = do n <- field_name - char ':' + _ <- char ':' b <- unstructured - crlf + _ <- crlf return (n,b) "optional (unspecified) header line" @@ -934,7 +928,7 @@ -- character. obs_qp :: CharParser a String -obs_qp = do char '\\' +obs_qp = do _ <- char '\\' c <- satisfy (\c -> ord c `elem` [0..127]) return ['\\',c] "any quoted US-ASCII character" @@ -973,9 +967,9 @@ obs_phrase = do r1 <- word r2 <- many $ choice [ word , string "." - , do { cfws; return [] } + , do { _ <- cfws; return [] } ] - return (r1 : (filter (/=[]) r2)) + return (r1 : filter (/=[]) r2) -- |Match a \"phrase list\" syntax and return the list of 'String's -- that make up the phrase. In contrast to a 'phrase', the @@ -984,7 +978,7 @@ obs_phrase_list :: CharParser a [String] obs_phrase_list = do r1 <- many1 (do r <- option [] phrase - unfold $ char ',' + _ <- unfold $ char ',' return (filter (/=[]) r)) r2 <- option [] phrase return (concat r1 ++ r2) @@ -1066,9 +1060,9 @@ , do { r <- oneOf ['A'..'I']; return $ (ord r - 64) * 60*60 } "military zone spec" , do { r <- oneOf ['K'..'M']; return $ (ord r - 65) * 60*60 } "military zone spec" , do { r <- oneOf ['N'..'Y']; return $ -(ord r - 77) * 60*60 } "military zone spec" - , do { char 'Z'; return 0 } "military zone spec" + , do { _ <- char 'Z'; return 0 } "military zone spec" ] - where mkZone n o = try $ do { string n; return (o*60*60) } + where mkZone n o = try $ do { _ <- string n; return (o*60*60) } -- * Obsolete Addressing (section 4.4) @@ -1095,10 +1089,10 @@ -- actual 'addr_spec' address. obs_angle_addr :: CharParser a String -obs_angle_addr = unfold (do char '<' +obs_angle_addr = unfold (do _ <- char '<' _ <- option [] obs_route addr <- addr_spec - char '>' + _ <- char '>' return addr) -- TODO: route is lost here. "obsolete angle address" @@ -1107,7 +1101,7 @@ -- 'obs_domain_list' for the actual parsing. obs_route :: CharParser a [String] -obs_route = unfold (do { r <- obs_domain_list; char ':'; return r }) +obs_route = unfold (do { r <- obs_domain_list; _ <- char ':'; return r }) "route of an obsolete angle address" -- |This parser parses a list of domain names, each of them prefaced @@ -1115,11 +1109,11 @@ -- 'domain's is returned - and may be empty. obs_domain_list :: CharParser a [String] -obs_domain_list = do char '@' +obs_domain_list = do _ <- char '@' r1 <- domain - r2 <- many (do cfws <|> string "," + r2 <- many (do _ <- cfws <|> string "," optional cfws - char '@' + _ <- char '@' r <- domain return r) return (r1 : r2) @@ -1131,7 +1125,7 @@ obs_local_part :: CharParser a String obs_local_part = do r1 <- word - r2 <- many (do string "." + r2 <- many (do _ <- string "." r <- word return ('.' : r)) return (r1 ++ concat r2) @@ -1143,7 +1137,7 @@ obs_domain :: CharParser a String obs_domain = do r1 <- atom - r2 <- many (do string "." + r2 <- many (do _ <- string "." r <- atom return ('.' : r)) return (r1 ++ concat r2) @@ -1169,7 +1163,7 @@ obs_mbox_list :: CharParser a [NameAddr] obs_mbox_list = do r1 <- many1 (try (do r <- maybeOption mailbox - unfold $ char ',' + _ <- unfold $ char ',' return r)) r2 <- maybeOption mailbox return [x | Just x <- r1 ++ [r2]] @@ -1184,7 +1178,7 @@ obs_addr_list :: CharParser a [NameAddr] obs_addr_list = do r1 <- many1 (try (do r <- maybeOption address optional cfws - char ',' + _ <- char ',' optional cfws return r)) r2 <- maybeOption address @@ -1288,7 +1282,7 @@ -- folding and the obsolete phrase syntax. obs_in_reply_to :: CharParser a [String] -obs_in_reply_to = obs_header "In-Reply-To" (do r <- many ( do {phrase; return [] } +obs_in_reply_to = obs_header "In-Reply-To" (do r <- many ( do {_ <- phrase; return [] } <|> msg_id ) return (filter (/=[]) r)) @@ -1297,7 +1291,7 @@ -- folding and the obsolete phrase syntax. obs_references :: CharParser a [String] -obs_references = obs_header "References" (do r <- many ( do { phrase; return [] } +obs_references = obs_header "References" (do r <- many ( do { _ <- phrase; return [] } <|> msg_id ) return (filter (/=[]) r)) @@ -1409,9 +1403,9 @@ obs_optional :: CharParser a (String,String) obs_optional = do n <- field_name - many wsp - char ':' + _ <- many wsp + _ <- char ':' b <- unstructured - crlf + _ <- crlf return (n,b) "optional (unspecified) header line" diff --git a/example/message-test.hs b/example/message-test.hs --- a/example/message-test.hs +++ b/example/message-test.hs @@ -15,7 +15,7 @@ -- Make sure all lines are terminated by CRLF. fixEol :: String -> String -fixEol ('\r':'\n':xs) = '\r' : '\n' : (fixEol xs) -fixEol ('\n':xs) = '\r' : '\n' : (fixEol xs) -fixEol (x:xs) = x : (fixEol xs) +fixEol ('\r':'\n':xs) = '\r' : '\n' : fixEol xs +fixEol ('\n':xs) = '\r' : '\n' : fixEol xs +fixEol (x:xs) = x : fixEol xs fixEol [] = [] diff --git a/example/smtp-test.hs b/example/smtp-test.hs --- a/example/smtp-test.hs +++ b/example/smtp-test.hs @@ -9,5 +9,4 @@ main :: IO () main = do input <- getContents - mapM (print . parse smtpCmd "") [ l ++ "\r\n" | l <- lines input ] - return () + mapM_ (print . parse smtpCmd "") [ l ++ "\r\n" | l <- lines input ] diff --git a/hsemail.cabal b/hsemail.cabal --- a/hsemail.cabal +++ b/hsemail.cabal @@ -1,5 +1,5 @@ Name: hsemail -Version: 1.6 +Version: 1.7 Copyright: (c) 2004-2010 Peter Simons License: BSD3 License-File: LICENSE @@ -11,7 +11,7 @@ Description: Parsers for the syntax defined in RFC2821 and 2822 Cabal-Version: >= 1.6 Build-Type: Simple -Tested-With: GHC == 6.12.1 +Tested-With: GHC == 6.12.3 Extra-Source-Files: example/message-test.hs example/message-test.input