From: pho Date: Tue, 2 Feb 2010 05:48:56 +0000 (+0900) Subject: Suppress unused-do-bind warnings which GHC 6.12.1 emits X-Git-Tag: RELEASE-0_4_2~2 X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=9ac730212cb361eb10e5fe4ad0eec6758e2b200a Suppress unused-do-bind warnings which GHC 6.12.1 emits Ignore-this: 34cd87c0f801bcdac16ec23cfd3bd235 darcs-hash:20100202054856-62b54-a2e8d87f372299bf8670d9afe6457c92a80c2f8b.gz --- diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs index 5c3b9ee..8e1be58 100644 --- a/Network/HTTP/Lucu/Authorization.hs +++ b/Network/HTTP/Lucu/Authorization.hs @@ -51,8 +51,8 @@ instance Show AuthChallenge where authCredentialP :: Parser AuthCredential authCredentialP = allowEOF $! - do string "Basic" - many1 lws + do _ <- string "Basic" + _ <- many1 lws b64 <- many1 $ satisfy (\ c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index dd7465e..27deb74 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -13,18 +13,20 @@ import Numeric chunkHeaderP :: Num a => Parser a chunkHeaderP = do hexLen <- many1 hexDigit - extension - crlf + _ <- extension + _ <- crlf let [(len, _)] = readHex hexLen return len where extension :: Parser () - extension = do many $ do char ';' - token - char '=' - token <|> quotedStr - return () + extension = many ( char ';' >> + token >> + char '=' >> + ( token <|> quotedStr ) + ) + >> + return () {-# SPECIALIZE chunkHeaderP :: Parser Int #-} diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index 0771efa..27a8941 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -20,7 +20,7 @@ acceptEncodingListP = allowEOF $! listOf accEncP accEncP :: Parser (String, Maybe Double) accEncP = do coding <- token qVal <- option Nothing - $ do string ";q=" + $ do _ <- string ";q=" q <- qvalue return $ Just q return (normalizeCoding coding, qVal) diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 163f6bc..87d858c 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -174,12 +174,12 @@ fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] -} headersP :: Parser Headers headersP = do xs <- many header - crlf + _ <- crlf return $! toHeaders xs where header :: Parser (Strict.ByteString, Strict.ByteString) header = do name <- token - char ':' + _ <- char ':' -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 -- の記述はひどく曖昧であり、この動作が本當に間違って -- ゐるのかどうかも良く分からない。例へば @@ -187,7 +187,7 @@ headersP = do xs <- many header -- のか？直勸的には駄目さうに思へるが、そんな記述は見 -- 付からない。 contents <- many (lws <|> many1 text) - crlf + _ <- crlf let value = foldr (++) "" contents norm = normalize value return (C8.pack name, C8.pack norm) diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index 0f83bab..ca25640 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -33,13 +33,11 @@ httpVersionP :: Parser HttpVersion httpVersionP = string "HTTP/" >> -- 頻出するので高速化 - choice [ do string "1.0" - return $ HttpVersion 1 0 - , do string "1.1" - return $ HttpVersion 1 1 + choice [ string "1.0" >> return (HttpVersion 1 0) + , string "1.1" >> return (HttpVersion 1 1) -- 一般の場合 , do major <- many1 digit - char '.' + _ <- char '.' minor <- many1 digit return $ HttpVersion (read major) (read minor) ] diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 654e50d..bab8d72 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -53,7 +53,7 @@ import System.Posix.Signals runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO () runHttpd cnf tree fbs = withSocketsDo $ - do installHandler sigPIPE Ignore Nothing + do _ <- installHandler sigPIPE Ignore Nothing case cnfSSLConfig cnf of Nothing diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index e28238e..b7ceb40 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -55,18 +55,18 @@ parseMIMEType str = case parseStr mimeTypeP str of mimeTypeP :: Parser MIMEType mimeTypeP = allowEOF $! - do maj <- token - char '/' - min <- token + do maj <- token + _ <- char '/' + min <- token params <- many paramP return $ MIMEType maj min params where paramP :: Parser (String, String) - paramP = do many lws - char ';' - many lws - name <- token - char '=' + paramP = do _ <- many lws + _ <- char ';' + _ <- many lws + name <- token + _ <- char '=' value <- token <|> quotedStr return (name, value) diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index d94711a..145adf8 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -21,7 +21,6 @@ import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils -import System.IO -- |'Data.Map.Map' from extension to MIME Type. type ExtMap = Map String MIMEType @@ -56,14 +55,14 @@ extMapP = do xs <- many (comment <|> validLine <|> emptyLine) where spc = oneOf " \t" - comment = do many spc - char '#' - many $ satisfy (/= '\n') - return Nothing + comment = many spc >> + char '#' >> + ( many $ satisfy (/= '\n') ) >> + return Nothing - validLine = do many spc + validLine = do _ <- many spc mime <- mimeTypeP - many spc + _ <- many spc exts <- sepBy token (many spc) return $ Just (mime, exts) diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index e73b74d..c9684b1 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -53,19 +53,19 @@ instance Show ContDispo where multipartFormP :: String -> Parser [FormData] multipartFormP boundary = do parts <- many (partP boundary) - string "--" - string boundary - string "--" - crlf + _ <- string "--" + _ <- string boundary + _ <- string "--" + _ <- crlf eof return $ map partToFormData parts partP :: String -> Parser Part partP boundary - = do string "--" - string boundary - crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 + = do _ <- string "--" + _ <- string boundary + _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 hs <- headersP body <- bodyP boundary return $ Part hs body @@ -74,11 +74,11 @@ partP boundary bodyP :: String -> Parser L8.ByteString bodyP boundary = do body <- manyChar $ - do notFollowedBy $ do crlf - string "--" - string boundary + do notFollowedBy $ ( crlf >> + string "--" >> + string boundary ) anyChar - crlf + _ <- crlf return body @@ -146,10 +146,10 @@ contDispoP = do dispoType <- token return $ ContDispo dispoType params where paramP :: Parser (String, String) - paramP = do many lws - char ';' - many lws - name <- token - char '=' + paramP = do _ <- many lws + _ <- char ';' + _ <- many lws + name <- token + _ <- char '=' value <- token <|> quotedStr return (name, value) diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index f6c80dc..78e4818 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -17,7 +17,6 @@ module Network.HTTP.Lucu.Parser.Http ) where -import Data.List import Network.HTTP.Lucu.Parser -- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@. @@ -67,11 +66,10 @@ isToken c = c `seq` -- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any -- occurrences of LWS before and after each tokens. listOf :: Parser a -> Parser [a] -listOf p = p `seq` - do many lws - sepBy p $! do many lws - char ',' - many lws +listOf !p = do _ <- many lws + sepBy p $! do _ <- many lws + _ <- char ',' + many lws -- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $ -- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@ @@ -96,15 +94,15 @@ separator = satisfy isSeparator -- |'quotedStr' accepts a string surrounded by double quotation -- marks. Quotes can be escaped by backslashes. quotedStr :: Parser String -quotedStr = do char '"' +quotedStr = do _ <- char '"' xs <- many (qdtext <|> quotedPair) - char '"' + _ <- char '"' return $ foldr (++) "" xs where qdtext = do c <- satisfy (/= '"') return [c] - quotedPair = do char '\\' + quotedPair = do _ <- char '\\' c <- satisfy isChar return [c] diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs index f86b2b1..bc2c590 100644 --- a/Network/HTTP/Lucu/RFC1123DateTime.hs +++ b/Network/HTTP/Lucu/RFC1123DateTime.hs @@ -82,22 +82,22 @@ parseHTTPDateTime src httpDateTime :: Parser UTCTime -httpDateTime = do foldl (<|>) failP (map string weekStr) - char ',' - char ' ' +httpDateTime = do _ <- foldl (<|>) failP (map string weekStr) + _ <- char ',' + _ <- char ' ' day <- liftM read (count 2 digit) - char ' ' + _ <- char ' ' mon <- foldl (<|>) failP (map tryEqToFst (zip monthStr [1..])) - char ' ' + _ <- char ' ' year <- liftM read (count 4 digit) - char ' ' + _ <- char ' ' hour <- liftM read (count 2 digit) - char ':' + _ <- char ':' min <- liftM read (count 2 digit) - char ':' + _ <- char ':' sec <- liftM read (count 2 digit) :: Parser Int - char ' ' - string "GMT" + _ <- char ' ' + _ <- string "GMT" eof let julianDay = fromGregorian year mon day timeOfDay = TimeOfDay hour min (fromIntegral sec) diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 044ba22..712a610 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -45,7 +45,7 @@ instance HasHeaders Request where requestP :: Parser Request -requestP = do many crlf +requestP = do _ <- many crlf (method, uri, version) <- requestLineP headers <- headersP return Request { @@ -58,11 +58,11 @@ requestP = do many crlf requestLineP :: Parser (Method, URI, HttpVersion) requestLineP = do method <- methodP - sp + _ <- sp uri <- uriP - sp + _ <- sp ver <- httpVersionP - crlf + _ <- crlf return (method, uri, ver) diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index cb0ce5c..e724489 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -119,7 +119,7 @@ requestReader !cnf !tree !fbs !h !addr !tQueue do let itr = oldItr { itrResourcePath = Just rsrcPath } requestHasBody <- readItr itr itrRequestHasBody id enqueue itr - return $ do runResource rsrcDef itr + return $ do _ <- runResource rsrcDef itr if requestHasBody then observeRequest itr input else