diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +0.4.2 -> 0.4.3 (2015-04-06) +--------------------------- + + - Parser for IMAP LIST to return mailbox names unquoted + (see https://github.com/jtdaugherty/HaskellNet/issues/34) + - Update to build with GHC 7.10.1 + 0.4.1 -> 0.4.2 -------------- diff --git a/HaskellNet.cabal b/HaskellNet.cabal --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -4,7 +4,7 @@ SMTP, and IMAP protocols. NOTE: this package will be split into smaller, protocol-specific packages in the future. -Version: 0.4.2 +Version: 0.4.3 Copyright: (c) 2006 Jun Mukai Author: Jun Mukai Maintainer: Jonathan Daugherty , diff --git a/example/imap.hs b/example/imap.hs --- a/example/imap.hs +++ b/example/imap.hs @@ -1,6 +1,6 @@ -import System.IO +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + import Network.HaskellNet.IMAP -import qualified Data.ByteString.Char8 as BS import Control.Monad imapServer = "imap.mail.org" @@ -11,8 +11,8 @@ con <- connectIMAP imapServer login con username password mboxes <- list con - mapM print mboxes + mapM_ print mboxes select con "INBOX" msgs <- search con [ALLs] - mapM_ (\x -> print x) (take 4 msgs) - forM_ (take 4msgs) (\x -> fetch con x >>= print) + mapM_ print (take 4 msgs) + forM_ (take 4msgs) (fetch con >=> print) diff --git a/src/Network/HaskellNet/IMAP/Parsers.hs b/src/Network/HaskellNet/IMAP/Parsers.hs --- a/src/Network/HaskellNet/IMAP/Parsers.hs +++ b/src/Network/HaskellNet/IMAP/Parsers.hs @@ -110,7 +110,7 @@ Parser pSearch = do untagged <- many (pSearchLine <|> pOtherLine) resp <- Parser pDone - let (mboxUp, searchRes) = mkMboxUpdate untagged + let (mboxUp, searchRes) = mkMboxUpdate untagged return (resp, mboxUp, concat searchRes) @@ -165,7 +165,7 @@ ; char ')' ; return $ PERMANENTFLAGS fs } , string "READ-ONLY" >> return READ_ONLY - , string "READ-WRITE" >> return READ_WRITE + , string "READ-WRITE" >> return READ_WRITE , string "TRYCREATE" >> return TRYCREATE , do { string "UNSEEN" >> space ; num <- many1 digit @@ -229,11 +229,12 @@ pListLine :: String -> Parser RespDerivs (Either a ([Attribute], String, MailboxName)) -pListLine list = +pListLine list = do string "* " >> string list >> space attrs <- parseAttrs sep <- parseSep mbox <- parseMailbox + anyChar `manyTill` crlfP return $ Right (attrs, sep, mbox) where parseAttr = do char '\\' @@ -248,7 +249,7 @@ char ')' return attrs parseSep = space >> char '"' >> anyChar `manyTill` char '"' - parseMailbox = space >> anyChar `manyTill` crlfP + parseMailbox = space >> char '"' >> anyChar `manyTill` char '"' pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)]) pStatusLine = @@ -294,7 +295,7 @@ ; fs <- pFlag `sepBy` space ; char ')' ; return $ \mbox -> - mbox { _isFlagWritable = + mbox { _isFlagWritable = Keyword "*" `elem` fs , _permanentFlags = filter (/= Keyword "*") fs } } diff --git a/src/Text/Packrat/Parse.hs b/src/Text/Packrat/Parse.hs --- a/src/Text/Packrat/Parse.hs +++ b/src/Text/Packrat/Parse.hs @@ -11,6 +11,8 @@ import Text.Packrat.Pos import Control.Monad +import Control.Applicative (Applicative(..)) +import qualified Control.Applicative as A -- Data types @@ -37,10 +39,21 @@ infixl 1 infixl 1 -instance Derivs d => Monad (Parser d) where +instance Derivs d => Functor (Parser d) where + f `fmap` (Parser p1) = Parser $ parse . p1 + where parse (Parsed val rem err) = + let val2 = f val + in Parsed val2 rem err + parse (NoParse err) = NoParse err + +instance Derivs d => Applicative (Parser d) where + pure x = Parser (\dvs -> Parsed x dvs (nullError dvs)) + (<*>) = ap + +instance Derivs d => Monad (Parser d) where (Parser p1) >>= f = Parser parse where parse dvs = first (p1 dvs) - first (Parsed val rem err) = + first (Parsed val rem err) = let Parser p2 = f val in second err (p2 rem) first (NoParse err) = NoParse err @@ -48,17 +61,21 @@ Parsed val rem (joinErrors err1 err) second err1 (NoParse err) = NoParse (joinErrors err1 err) - return x = Parser (\dvs -> Parsed x dvs (nullError dvs)) + return = pure fail msg = Parser (\dvs -> NoParse (msgError (dvPos dvs) msg)) +instance Derivs d => A.Alternative (Parser d) where + empty = Parser $ NoParse . nullError + (<|>) = (<|>) + instance Derivs d => MonadPlus (Parser d) where - mzero = Parser (\dvs -> NoParse $ nullError dvs) - mplus = (<|>) + mzero = A.empty + mplus = (A.<|>) (<|>) :: Derivs d => Parser d v -> Parser d v -> Parser d v (Parser p1) <|> (Parser p2) = Parser parse where parse dvs = first dvs (p1 dvs) - first _ (result @ (Parsed _ _ _)) = result + first _ (result @ (Parsed {})) = result first dvs (NoParse err) = second err (p2 dvs) second err1 (Parsed val rem err) = Parsed val rem (joinErrors err1 err) @@ -76,7 +93,7 @@ notFollowedBy :: (Derivs d, Show v) => Parser d v -> Parser d () notFollowedBy (Parser p) = Parser parse - where parse dvs = case (p dvs) of + where parse dvs = case p dvs of Parsed val _ _ -> NoParse (msgError (dvPos dvs) ("unexpected " ++ show val)) @@ -86,7 +103,7 @@ optional p = (do v <- p; return (Just v)) <|> return Nothing option :: Derivs d => v -> Parser d v -> Parser d v -option v p = (do v' <- p; return v') <|> return v +option v p = p <|> return v many :: Derivs d => Parser d v -> Parser d [v] many p = (do { v <- p; vs <- many p; return (v : vs) } ) @@ -96,7 +113,7 @@ many1 p = do { v <- p; vs <- many p; return (v : vs) } count :: Derivs d => Int -> Parser d v -> Parser d [v] -count n p = sequence $ replicate n p +count = replicateM sepBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v] sepBy1 p psep = do v <- p @@ -233,11 +250,11 @@ ParseError p1 _ <= ParseError p2 _ = p1 <= p2 ParseError p1 _ >= ParseError p2 _ = p1 >= p2 -- Special behavior: "max" joins two errors - max p1 p2 = joinErrors p1 p2 + max = joinErrors min _ _ = undefined instance Show ParseError where - show (ParseError pos []) = + show (ParseError pos []) = show pos ++ ": unknown error" show (ParseError pos msgs) = expectmsg expects ++ messages msgs where expects = getExpects msgs @@ -265,14 +282,14 @@ anyChar = Parser dvChar char :: Derivs d => Char -> Parser d Char -char ch = satisfy anyChar (\c -> c == ch) show ch +char ch = satisfy anyChar (== ch) show ch oneOf :: Derivs d => [Char] -> Parser d Char -oneOf chs = satisfy anyChar (\c -> c `elem` chs) +oneOf chs = satisfy anyChar (`elem` chs) ("one of the characters " ++ show chs) noneOf :: Derivs d => [Char] -> Parser d Char -noneOf chs = satisfy anyChar (\c -> not (c `elem` chs)) +noneOf chs = satisfy anyChar (`notElem` chs) ("any character not in " ++ show chs) @@ -332,7 +349,7 @@ getDerivs = Parser (\dvs -> Parsed dvs dvs (nullError dvs)) setDerivs :: Derivs d => d -> Parser d () -setDerivs newdvs = Parser (\dvs -> Parsed () newdvs (nullError dvs)) +setDerivs newdvs = Parser (Parsed () newdvs . nullError) getPos :: Derivs d => Parser d Pos getPos = Parser (\dvs -> Parsed (dvPos dvs) dvs (nullError dvs)) @@ -344,5 +361,5 @@ dvString d = case dvChar d of NoParse _ -> [] - Parsed c rem _ -> (c : dvString rem) + Parsed c rem _ -> c : dvString rem