Cosmetic changes suggested by hlint

Ignore-this: 28bf8a64b9fcc04a983b14d4893ca14f

darcs-hash:20091110054904-62b54-30cdb8d478c8a477e4b38cff03d296e71791bacf.gz

diff --git a/.boring b/.boring
index e8b77c91dac04372436dc3df21721167b8d69ac9..408e6f45bd7cddceabdf2f772e96198bffe7a9c6 100644 (file)
--- a/.boring
+++ b/.boring
@@ -53,6 +53,7 @@
 ^Setup$
 ^\.setup-config$
 ^.installed-pkg-config$
 ^Setup$
 ^\.setup-config$
 ^.installed-pkg-config$

+^report\.html$

 ^data/CompileMimeTypes$
 
 ^examples/HelloWorld$
 ^data/CompileMimeTypes$
 
 ^examples/HelloWorld$

diff --git a/ImplantFile.hs b/ImplantFile.hs
index ae749b9886c5a7422cd25bceb2137a83debb796f..1d7d43d8ce21f51666bb53b3b4652d94f37de063 100644 (file)
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -78,11 +78,11 @@ main :: IO ()
 main = withOpenSSL $
        do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
 
 main = withOpenSSL $
        do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
 

-          when (not $ null errors)
+          unless (null errors)

                    $ do mapM_ putStr errors
                         exitWith $ ExitFailure 1
 
                    $ do mapM_ putStr errors
                         exitWith $ ExitFailure 1
 

-          when (any (\ x -> x == OptHelp) opts)
+          when (any (== OptHelp) opts)

                    $ do printUsage
                         exitWith ExitSuccess
 
                    $ do printUsage
                         exitWith ExitSuccess
 


@@ -106,7 +106,7 @@ generateHaskellSource opts srcFile
          output   <- openOutput opts
          eTag     <- getETag opts input
 
          output   <- openOutput opts
          eTag     <- getETag opts input
 

-         let compParams  = defaultCompressParams { compressLevel = BestCompression }
+         let compParams  = defaultCompressParams { compressLevel = bestCompression }

              gzippedData = compressWith compParams input
              originalLen = L.length input
              gzippedLen  = L.length gzippedData
              gzippedData = compressWith compParams input
              originalLen = L.length input
              gzippedLen  = L.length gzippedData


@@ -371,12 +371,12 @@ getSymbolName opts modName
                                             _            -> False) opts
           -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
           -- 小文字にしたものを使ふ。
                                             _            -> False) opts
           -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
           -- 小文字にしたものを使ふ。

-          defaultSymName = mkDefault modName
-          mkDefault      = headToLower . getLastComp
-          headToLower    = \ str -> case str of
-                                      []     -> error "module name must not be empty"
-                                      (x:xs) -> toLower x : xs
-          getLastComp    = reverse . fst . break (== '.') . reverse
+          defaultSymName  = mkDefault modName
+          mkDefault       = headToLower . getLastComp
+          headToLower str = case str of
+                              []     -> error "module name must not be empty"
+                              (x:xs) -> toLower x : xs
+          getLastComp     = reverse . fst . break (== '.') . reverse

       in
         case symNameOpts of
           []                      -> return defaultSymName
       in
         case symNameOpts of
           []                      -> return defaultSymName


@@ -400,8 +400,8 @@ getMIMEType opts srcFile
 
 getLastModified :: FilePath -> IO UTCTime
 getLastModified "-"   = getCurrentTime
 
 getLastModified :: FilePath -> IO UTCTime
 getLastModified "-"   = getCurrentTime

-getLastModified fpath = getFileStatus fpath
-                        >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime
+getLastModified fpath = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime)
+                        $ getFileStatus fpath

 
 
 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
 
 
 getETag :: [CmdOpt] -> Lazy.ByteString -> IO String


@@ -411,25 +411,26 @@ getETag opts input
                                       _         -> False) opts
       in
         case eTagOpts of
                                       _         -> False) opts
       in
         case eTagOpts of

-          []               -> getDigestByName "SHA1" >>= return . mkETagFromInput . fromJust
+          []               -> fmap (mkETagFromInput . fromJust) (getDigestByName "SHA1")

           (OptETag str):[] -> return str
           _                -> error "too many --etag options."
     where
       mkETagFromInput :: Digest -> String
           (OptETag str):[] -> return str
           _                -> error "too many --etag options."
     where
       mkETagFromInput :: Digest -> String

-      mkETagFromInput sha1 = "SHA-1:" ++ (toHex $ digestLBS sha1 input)
+      mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)

 
 

-      toHex :: [Char] -> String
-      toHex []     = ""
-      toHex (x:xs) = hexByte (fromEnum x) ++ toHex xs
+      toHex :: String -> String
+      toHex = foldr ((++) . hexByte . fromEnum) ""

 
       hexByte :: Int -> String
       hexByte n
 
       hexByte :: Int -> String
       hexByte n

-          = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []
+          = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
+            , hex4bit ( n             .&. 0x0F)
+            ]

 
       hex4bit :: Int -> Char
       hex4bit n
 
       hex4bit :: Int -> Char
       hex4bit n

-          | n < 10    = (chr $ ord '0' + n     )
-          | n < 16    = (chr $ ord 'a' + n - 10)
+          | n < 10    = chr $ ord '0' + n
+          | n < 16    = chr $ ord 'a' + n - 10

           | otherwise = undefined
 
 
           | otherwise = undefined
 
 

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index 33f22abb9045ca962e4ef9a62449b34d56662296..6d36ea8e89ec1b822b30004fecf466c1669baf7b 100644 (file)
--- a/Network/HTTP/Lucu/Abortion.hs
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -109,7 +109,6 @@ abortPage conf reqM res abo
         Nothing
             -> let res'  = res { resStatus = aboStatus abo }
                    res'' = foldl (.) id [setHeader name value
         Nothing
             -> let res'  = res { resStatus = aboStatus abo }
                    res'' = foldl (.) id [setHeader name value

-                                             | (name, value) <- fromHeaders $ aboHeaders abo]
-                           $ res'
+                                             | (name, value) <- fromHeaders $ aboHeaders abo] res'

                in
                  getDefaultPage conf reqM res''
                in
                  getDefaultPage conf reqM res''

diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs
index 37adda38768ab793862f3c692353665d33d36b3c..0771efa91ace3e052f43d5b298597270c04a3c79 100644 (file)
--- a/Network/HTTP/Lucu/ContentCoding.hs
+++ b/Network/HTTP/Lucu/ContentCoding.hs
@@ -7,6 +7,7 @@ module Network.HTTP.Lucu.ContentCoding
     where
 
 import           Data.Char
     where
 
 import           Data.Char

+import           Data.Ord

 import           Data.Maybe
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Parser.Http
 import           Data.Maybe
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Parser.Http


@@ -43,4 +44,5 @@ unnormalizeCoding coding
 
 orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering
 orderAcceptEncodings (_, q1) (_, q2)
 
 orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering
 orderAcceptEncodings (_, q1) (_, q2)

-    = fromMaybe 0 q1 `compare` fromMaybe 0 q2
+    = comparing (fromMaybe 0) q1 q2
+

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 6a980104d3dfe6a1f6d9b66202b9898aaa0ae1fd..cbbf674718e922957ce57389ae32aa8454b9b87a 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -29,9 +29,8 @@ import           Text.XML.HXT.DOM.XmlKeywords
 
 
 getDefaultPage :: Config -> Maybe Request -> Response -> String
 
 
 getDefaultPage :: Config -> Maybe Request -> Response -> String

-getDefaultPage conf req res
-    = conf `seq` req `seq` res `seq`
-      let msgA = getMsg req res
+getDefaultPage !conf !req !res
+    = let msgA = getMsg req res

       in
         unsafePerformIO $
         do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
       in
         unsafePerformIO $
         do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA


@@ -42,10 +41,9 @@ getDefaultPage conf req res
 
 
 writeDefaultPage :: Interaction -> STM ()
 
 
 writeDefaultPage :: Interaction -> STM ()

-writeDefaultPage itr
-    = itr `seq`
-      -- Content-Type が正しくなければ補完できない。
-      do res <- readItr itr itrResponse id
+writeDefaultPage !itr
+    -- Content-Type が正しくなければ補完できない。
+    = do res <- readItr itr itrResponse id

          when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
                   $ do reqM <- readItr itr itrRequest id
 
          when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
                   $ do reqM <- readItr itr itrRequest id
 


@@ -57,9 +55,8 @@ writeDefaultPage itr
 
 
 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
 
 
 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree

-mkDefaultPage conf status msgA
-    = conf `seq` status `seq` msgA `seq`
-      let (# sCode, sMsg #) = statusCode status
+mkDefaultPage !conf !status !msgA
+    = let (# sCode, sMsg #) = statusCode status

           sig               = C8.unpack (cnfServerSoftware conf)
                               ++ " at "
                               ++ C8.unpack (cnfServerHost conf)
           sig               = C8.unpack (cnfServerSoftware conf)
                               ++ " at "
                               ++ C8.unpack (cnfServerHost conf)


@@ -85,9 +82,8 @@ mkDefaultPage conf status msgA
 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
 
 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
 
 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree

-getMsg req res
-    = req `seq` res `seq`
-      case resStatus res of
+getMsg !req !res
+    = case resStatus res of

         -- 1xx は body を持たない
         -- 2xx の body は補完しない
 
         -- 1xx は body を持たない
         -- 2xx の body は補完しない
 

diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs
index f017f5e6a81ef1093354d0efb9970948fae1d1a1..93c2cda9ea065214d84463c40a434dfbf4759cf2 100644 (file)
--- a/Network/HTTP/Lucu/Format.hs
+++ b/Network/HTTP/Lucu/Format.hs
@@ -24,7 +24,7 @@ fmtInt base upperCase minWidth pad forceSign n
     where
       fmt' :: Int -> String
       fmt' m
     where
       fmt' :: Int -> String
       fmt' m

-          | m < base  = (intToChar upperCase m) : []
+          | m < base  = [intToChar upperCase m]

           | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base)
 
 
           | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base)
 
 


@@ -40,50 +40,54 @@ fmtDec minWidth n
 fmtDec2 :: Int -> String
 fmtDec2 n
     | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback
 fmtDec2 :: Int -> String
 fmtDec2 n
     | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback

-    | n < 10            =   '0'
-                          : intToChar undefined n
-                          : []
-    | otherwise         =   intToChar undefined (n `div` 10)
-                          : intToChar undefined (n `mod` 10)
-                          : []
+    | n < 10            = [ '0'
+                          , intToChar undefined n
+                          ]
+    | otherwise         = [ intToChar undefined (n `div` 10)
+                          , intToChar undefined (n `mod` 10)
+                          ]

 
 
 fmtDec3 :: Int -> String
 fmtDec3 n
     | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback
 
 
 fmtDec3 :: Int -> String
 fmtDec3 n
     | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback

-    | n < 10             = '0' : '0'
-                           : intToChar undefined n
-                           : []
-    | n < 100            = '0'
-                           : intToChar undefined ((n `div` 10) `mod` 10)
-                           : intToChar undefined ( n           `mod` 10)
-                           : []
-    | otherwise          =   intToChar undefined ((n `div` 100) `mod` 10)
-                           : intToChar undefined ((n `div`  10) `mod` 10)
-                           : intToChar undefined ( n            `mod` 10)
-                           : []
+    | n < 10             = [ '0'
+                           , '0'
+                           , intToChar undefined n
+                           ]
+    | n < 100            = [ '0'
+                           , intToChar undefined ((n `div` 10) `mod` 10)
+                           , intToChar undefined ( n           `mod` 10)
+                           ]
+    | otherwise          = [ intToChar undefined ((n `div` 100) `mod` 10)
+                           , intToChar undefined ((n `div`  10) `mod` 10)
+                           , intToChar undefined ( n            `mod` 10)
+                           ]

 
 
 fmtDec4 :: Int -> String
 fmtDec4 n
     | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback
 
 
 fmtDec4 :: Int -> String
 fmtDec4 n
     | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback

-    | n < 10              =   '0' : '0' : '0'
-                            : intToChar undefined n
-                            : []
-    | n < 100             =   '0' : '0'
-                            : intToChar undefined ((n `div` 10) `mod` 10)
-                            : intToChar undefined ( n           `mod` 10)
-                            : []
-    | n < 1000            =   '0'
-                            : intToChar undefined ((n `div` 100) `mod` 10)
-                            : intToChar undefined ((n `div`  10) `mod` 10)
-                            : intToChar undefined ( n            `mod` 10)
-                            : []
-    | otherwise           =   intToChar undefined ((n `div` 1000) `mod` 10)
-                            : intToChar undefined ((n `div`  100) `mod` 10)
-                            : intToChar undefined ((n `div`   10) `mod` 10)
-                            : intToChar undefined ( n             `mod` 10)
-                            : []
+    | n < 10              = [ '0'
+                            , '0'
+                            , '0'
+                            , intToChar undefined n
+                            ]
+    | n < 100             = [ '0'
+                            , '0'
+                            , intToChar undefined ((n `div` 10) `mod` 10)
+                            , intToChar undefined ( n           `mod` 10)
+                            ]
+    | n < 1000            = [ '0'
+                            , intToChar undefined ((n `div` 100) `mod` 10)
+                            , intToChar undefined ((n `div`  10) `mod` 10)
+                            , intToChar undefined ( n            `mod` 10)
+                            ]
+    | otherwise           = [ intToChar undefined ((n `div` 1000) `mod` 10)
+                            , intToChar undefined ((n `div`  100) `mod` 10)
+                            , intToChar undefined ((n `div`   10) `mod` 10)
+                            , intToChar undefined ( n             `mod` 10)
+                            ]

 
 
 fmtHex :: Bool -> Int -> Int -> String
 
 
 fmtHex :: Bool -> Int -> Int -> String

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index febbdb6271ae362dd5e3c9a57fdff0975f68771f..163f6bcf55bb2a9e4f78ef680919be07df354246 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -21,6 +21,7 @@ import           Data.Char
 import           Data.List
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.List
 import           Data.Map (Map)
 import qualified Data.Map as M

+import           Data.Ord

 import           Data.Word
 import           Foreign.ForeignPtr
 import           Foreign.Ptr
 import           Data.Word
 import           Foreign.ForeignPtr
 import           Foreign.Ptr


@@ -76,7 +77,7 @@ noCaseCmp' p1 l1 p2 l2
     | otherwise
         = do c1 <- peek p1
              c2 <- peek p2
     | otherwise
         = do c1 <- peek p1
              c2 <- peek p2

-             case toLower (w2c c1) `compare` toLower (w2c c2) of
+             case comparing (toLower . w2c) c1 c2 of

                EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
                x  -> return x
 
                EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
                x  -> return x
 


@@ -194,7 +195,7 @@ headersP = do xs <- many header
       normalize :: String -> String
       normalize = trimBody . trim isWhiteSpace
 
       normalize :: String -> String
       normalize = trimBody . trim isWhiteSpace
 

-      trimBody = foldr (++) []
+      trimBody = concat

                  . map (\ s -> if head s == ' ' then
                                    " "
                                else
                  . map (\ s -> if head s == ' ' then
                                    " "
                                else

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 6b5cdae11a708ddf3c36b26e81bfd581fa572064..5da428d4968ff225e31ac84fa003f013fbdf3d77 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -84,8 +84,8 @@ defaultPageContentType = C8.pack "application/xhtml+xml"
 
 newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
 newInteraction !conf !addr !cert !req
 
 newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
 newInteraction !conf !addr !cert !req

-    = do request  <- newTVarIO $ req
-         responce <- newTVarIO $ Response {
+    = do request  <- newTVarIO req
+         responce <- newTVarIO Response {

                        resVersion = HttpVersion 1 1
                      , resStatus  = Ok
                      , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]
                        resVersion = HttpVersion 1 1
                      , resStatus  = Ok
                      , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]


@@ -115,7 +115,7 @@ newInteraction !conf !addr !cert !req
          wroteContinue <- newTVarIO False
          wroteHeader   <- newTVarIO False
 
          wroteContinue <- newTVarIO False
          wroteHeader   <- newTVarIO False
 

-         return $ Interaction {
+         return Interaction {

                       itrConfig       = conf
                     , itrRemoteAddr   = addr
                     , itrRemoteCert   = cert
                       itrConfig       = conf
                     , itrRemoteAddr   = addr
                     , itrRemoteCert   = cert


@@ -150,33 +150,28 @@ newInteraction !conf !addr !cert !req
 
 
 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
 
 
 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()

-writeItr itr accessor value
-    = itr `seq` accessor `seq` value `seq`
-      writeTVar (accessor itr) value
+writeItr !itr !accessor !value
+    = writeTVar (accessor itr) value

 
 
 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
 
 
 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b

-readItr itr accessor reader
-    = itr `seq` accessor `seq` reader `seq`
-      readTVar (accessor itr) >>= return . reader
+readItr !itr !accessor !reader
+    = fmap reader $ readTVar (accessor itr)

 
 
 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
 
 
 readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)

-readItrF itr accessor reader
-    = itr `seq` accessor `seq` reader `seq`
-      readItr itr accessor (fmap reader)
+readItrF !itr !accessor !reader
+    = readItr itr accessor (fmap reader)

 {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
 
 
 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
 {-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
 
 
 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()

-updateItr itr accessor updator
-    = itr `seq` accessor `seq` updator `seq`
-      do old <- readItr itr accessor id
+updateItr !itr !accessor !updator
+    = do old <- readItr itr accessor id

          writeItr itr accessor (updator old)
 
 
 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
          writeItr itr accessor (updator old)
 
 
 updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()

-updateItrF itr accessor updator
-    = itr `seq` accessor `seq` updator `seq`
-      updateItr itr accessor (fmap updator)
+updateItrF !itr !accessor !updator
+    = updateItr itr accessor (fmap updator)

 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file
 {-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index 9a36ad5d83978048d3414b26090146db576a9562..d08a145f5bc47b1de9fbde9d3e1944000d75c617 100644 (file)
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -93,6 +93,9 @@ instance Monad Parser where
     return !x = Parser $! return $! Success x
     fail _    = Parser $! return $! IllegalInput
 
     return !x = Parser $! return $! Success x
     fail _    = Parser $! return $! IllegalInput
 

+instance Functor Parser where
+    fmap f p = p >>= return . f
+

 -- |@'failP'@ is just a synonym for @'Prelude.fail'
 -- 'Prelude.undefined'@.
 failP :: Parser a
 -- |@'failP'@ is just a synonym for @'Prelude.fail'
 -- 'Prelude.undefined'@.
 failP :: Parser a

diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
index adbda7b7e81bb3d863afa8b1b2a43e6012d2cd68..f6c80dc8072f65abb76deec29c6fc0f6addc476f 100644 (file)
--- a/Network/HTTP/Lucu/Parser/Http.hs
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -87,7 +87,7 @@ lws = do s  <- option "" crlf
 
 -- |'text' accepts one character which doesn't satisfy 'isCtl'.
 text :: Parser Char
 
 -- |'text' accepts one character which doesn't satisfy 'isCtl'.
 text :: Parser Char

-text = satisfy (\ c -> not (isCtl c))
+text = satisfy (not . isCtl)

 
 -- |'separator' accepts one character which satisfies 'isSeparator'.
 separator :: Parser Char
 
 -- |'separator' accepts one character which satisfies 'isSeparator'.
 separator :: Parser Char

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index d3659cc78905f89082d70824b5e0f621ab316fb9..489a4f9aa89c7c7ae74a7d557ddb28b4eab78d3e 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -56,13 +56,12 @@ import           System.IO.Unsafe
 -}
 
 postprocess :: Interaction -> STM ()
 -}
 
 postprocess :: Interaction -> STM ()

-postprocess itr
-    = itr `seq`
-      do reqM <- readItr itr itrRequest id
+postprocess !itr
+    = do reqM <- readItr itr itrRequest id

          res  <- readItr itr itrResponse id
          let sc = resStatus res
 
          res  <- readItr itr itrResponse id
          let sc = resStatus res
 

-         when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError])
+         unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError])

                   $ abortSTM InternalServerError []
                         $ Just ("The status code is not good for a final status: "
                                 ++ show sc)
                   $ abortSTM InternalServerError []
                         $ Just ("The status code is not good for a final status: "
                                 ++ show sc)


@@ -119,10 +118,8 @@ postprocess itr
                conn <- readHeader (C8.pack "Connection")
                case conn of
                  Nothing    -> return ()
                conn <- readHeader (C8.pack "Connection")
                case conn of
                  Nothing    -> return ()

-                 Just value -> if value `noCaseEq` C8.pack "close" then
-                                   writeItr itr itrWillClose True
-                               else
-                                   return ()
+                 Just value -> when (value `noCaseEq` C8.pack "close")
+                                   $ writeItr itr itrWillClose True

 
                willClose <- readItr itr itrWillClose id
                when willClose
 
                willClose <- readItr itr itrWillClose id
                when willClose


@@ -132,20 +129,17 @@ postprocess itr
                         $ writeTVar (itrWillDiscardBody itr) True
 
       readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
                         $ writeTVar (itrWillDiscardBody itr) True
 
       readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)

-      readHeader name
-          = name `seq`
-            readItr itr itrResponse $ getHeader name
+      readHeader !name
+          = readItr itr itrResponse $ getHeader name

 
       updateRes :: (Response -> Response) -> STM ()
 
       updateRes :: (Response -> Response) -> STM ()

-      updateRes updator 
-          = updator `seq`
-            updateItr itr itrResponse updator
+      updateRes !updator 
+          = updateItr itr itrResponse updator

 
 
 completeUnconditionalHeaders :: Config -> Response -> IO Response
 
 
 completeUnconditionalHeaders :: Config -> Response -> IO Response

-completeUnconditionalHeaders conf res
-    = conf `seq` res `seq`
-      return res >>= compServer >>= compDate >>= return
+completeUnconditionalHeaders !conf !res
+    = compServer res >>= compDate

       where
         compServer res'
             = case getHeader (C8.pack "Server") res' of
       where
         compServer res'
             = case getHeader (C8.pack "Server") res' of


@@ -177,7 +171,6 @@ getCurrentDate = do now                     <- getCurrentTime
     where
       mostlyEq :: UTCTime -> UTCTime -> Bool
       mostlyEq a b
     where
       mostlyEq :: UTCTime -> UTCTime -> Bool
       mostlyEq a b

-          = if utctDay a == utctDay b then
-                fromEnum (utctDayTime a) == fromEnum (utctDayTime b)
-            else
-                False
+          = (utctDay a == utctDay b)
+            &&
+            (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 6191273183347674fbaaf348565e5b3e76ee040d..de5efaae4ac5bce5d23bab1658609092a95f8df4 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -100,7 +100,7 @@ preprocess itr
                          portStr
                               = case port of
                                   Just 80 -> Just ""
                          portStr
                               = case port of
                                   Just 80 -> Just ""

-                                  Just n  -> Just $ ":" ++ show n
+                                  Just n  -> Just $ ':' : show n

                                   Nothing -> Nothing
                      case portStr of
                        Just str -> updateAuthority host (C8.pack str)
                                   Nothing -> Nothing
                      case portStr of
                        Just str -> updateAuthority host (C8.pack str)


@@ -110,10 +110,10 @@ preprocess itr
                        -- いと思ふ。stderr？
                        Nothing  -> setStatus InternalServerError
               else
                        -- いと思ふ。stderr？
                        Nothing  -> setStatus InternalServerError
               else

-                  do case getHeader (C8.pack "Host") req of
-                       Just str -> let (host, portStr) = parseHost str
-                                   in updateAuthority host portStr
-                       Nothing  -> setStatus BadRequest
+                  case getHeader (C8.pack "Host") req of
+                    Just str -> let (host, portStr) = parseHost str
+                                in updateAuthority host portStr
+                    Nothing  -> setStatus BadRequest

 
 
       parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
 
 
       parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)


@@ -148,13 +148,11 @@ preprocess itr
 
                case getHeader (C8.pack "Transfer-Encoding") req of
                  Nothing    -> return ()
 
                case getHeader (C8.pack "Transfer-Encoding") req of
                  Nothing    -> return ()

-                 Just value -> if value `noCaseEq` C8.pack "identity" then
-                                   return ()
-                               else
-                                   if value `noCaseEq` C8.pack "chunked" then
-                                       writeItr itr itrRequestIsChunked True
-                                   else
-                                       setStatus NotImplemented
+                 Just value -> unless (value `noCaseEq` C8.pack "identity")
+                                   $ if value `noCaseEq` C8.pack "chunked" then
+                                         writeItr itr itrRequestIsChunked True
+                                     else
+                                         setStatus NotImplemented

 
                case getHeader (C8.pack "Content-Length") req of
                  Nothing    -> return ()
 
                case getHeader (C8.pack "Content-Length") req of
                  Nothing    -> return ()


@@ -167,7 +165,5 @@ preprocess itr
 
                case getHeader (C8.pack "Connection") req of
                  Nothing    -> return ()
 
                case getHeader (C8.pack "Connection") req of
                  Nothing    -> return ()

-                 Just value -> if value `noCaseEq` C8.pack "close" then
-                                   writeItr itr itrWillClose True
-                               else
-                                   return ()
+                 Just value -> when (value `noCaseEq` C8.pack "close")
+                                   $ writeItr itr itrWillClose True

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index c98a400c0748ba2c01aa7e9978791d470ccc8833..044ba2241dbd039dc373710ef473adc23eccf6d8 100644 (file)
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -67,19 +67,19 @@ requestLineP = do method <- methodP
 
 
 methodP :: Parser Method
 
 
 methodP :: Parser Method

-methodP = (let methods = [ ("OPTIONS", OPTIONS)
-                         , ("GET"    , GET    )
-                         , ("HEAD"   , HEAD   )
-                         , ("POST"   , POST   )
-                         , ("PUT"    , PUT    )
-                         , ("DELETE" , DELETE )
-                         , ("TRACE"  , TRACE  )
-                         , ("CONNECT", CONNECT)
-                         ]
-           in foldl (<|>) failP $ map (\ (str, mth)
-                                           -> string str >> return mth) methods)
+methodP = ( let methods = [ ("OPTIONS", OPTIONS)
+                          , ("GET"    , GET    )
+                          , ("HEAD"   , HEAD   )
+                          , ("POST"   , POST   )
+                          , ("PUT"    , PUT    )
+                          , ("DELETE" , DELETE )
+                          , ("TRACE"  , TRACE  )
+                          , ("CONNECT", CONNECT)
+                          ]
+            in choice $ map (\ (str, mth)
+                                 -> string str >> return mth) methods )

           <|>
           <|>

-          token >>= return . ExtensionMethod
+          fmap ExtensionMethod token

 
 
 uriP :: Parser URI
 
 
 uriP :: Parser URI

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index de19e0470deb3f4951080895998939df1e5294c1..06fed17dd13c7d52af6d49e7f65ca3adcc164fb8 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -199,10 +199,10 @@ runResource def itr
                              driftTo Done
                         ) itr
                )
                              driftTo Done
                         ) itr
                )

-             $ \ exc -> processException exc
+               processException

     where
       fork :: IO () -> IO ThreadId
     where
       fork :: IO () -> IO ThreadId

-      fork = if (resUsesNativeThread def)
+      fork = if resUsesNativeThread def

              then forkOS
              else forkIO
       
              then forkOS
              else forkIO
       


@@ -223,12 +223,12 @@ runResource def itr
                       setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
 
       allowedMethods :: [String]
                       setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
 
       allowedMethods :: [String]

-      allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
-                                           , methods resHead   ["GET", "HEAD"]
-                                           , methods resPost   ["POST"]
-                                           , methods resPut    ["PUT"]
-                                           , methods resDelete ["DELETE"]
-                                           ]
+      allowedMethods = nub $ concat [ methods resGet    ["GET"]
+                                    , methods resHead   ["GET", "HEAD"]
+                                    , methods resPost   ["POST"]
+                                    , methods resPut    ["PUT"]
+                                    , methods resDelete ["DELETE"]
+                                    ]

 
       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
       methods f xs = case f def of
 
       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
       methods f xs = case f def of


@@ -253,7 +253,7 @@ runResource def itr
                if state <= DecidingHeader then
                    flip runRes itr
                       $ do setStatus $ aboStatus abo
                if state <= DecidingHeader then
                    flip runRes itr
                       $ do setStatus $ aboStatus abo

-                           mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo
+                           mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo

                            output $ abortPage conf reqM res abo
                  else
                    when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
                            output $ abortPage conf reqM res abo
                  else
                    when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 63174b7cb5ea3d8f727c860d77efdea0710134dd..6ad15e83575cdd9727fcd111178ca0299364a7f8 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -35,30 +35,28 @@ responseWriter !cnf !h !tQueue !readerTID
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
           = {-# SCC "awaitSomethingToWrite" #-}
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
           = {-# SCC "awaitSomethingToWrite" #-}

-            do action
-                   <- atomically $!
-                      -- キューが空でなくなるまで待つ
-                      do queue <- readTVar tQueue
-                         -- GettingBody 状態にあり、Continue が期待され
-                         -- ã\81¦ã\82\90ã\81¦ã\80\81ã\81\9dã\82\8cã\81\8cã\81¾ã\81 é\80\81ä¿¡å\89\8dã\81ªã\81®ã\81§ã\81\82ã\82\8cã\81°ã\80\81
-                         -- Continue を送信する。
-                         case S.viewr queue of
-                           EmptyR   -> retry
-                           _ :> itr -> do state <- readItr itr itrState id
+            join $!
+                 atomically $!
+                 -- キューが空でなくなるまで待つ
+                 do queue <- readTVar tQueue
+                    -- GettingBody 状態にあり、Continue が期待されてゐ
+                    -- ã\81¦ã\80\81ã\81\9dã\82\8cã\81\8cã\81¾ã\81 é\80\81ä¿¡å\89\8dã\81ªã\81®ã\81§ã\81\82ã\82\8cã\81°ã\80\81Continue ã\82\92é\80\81
+                    -- 信する。
+                    case S.viewr queue of
+                      EmptyR   -> retry
+                      _ :> itr -> do state <- readItr itr itrState id

 
 

-                                          if state == GettingBody then
-                                              writeContinueIfNecessary itr
-                                            else
-                                              if state >= DecidingBody then
-                                                  writeHeaderOrBodyIfNecessary itr
-                                              else
-                                                  retry
-               action
+                                     if state == GettingBody then
+                                         writeContinueIfNecessary itr
+                                       else
+                                         if state >= DecidingBody then
+                                             writeHeaderOrBodyIfNecessary itr
+                                         else
+                                             retry

 
       writeContinueIfNecessary :: Interaction -> STM (IO ())
 
       writeContinueIfNecessary :: Interaction -> STM (IO ())

-      writeContinueIfNecessary itr
+      writeContinueIfNecessary !itr

           = {-# SCC "writeContinueIfNecessary" #-}
           = {-# SCC "writeContinueIfNecessary" #-}

-            itr `seq`

             do expectedContinue <- readItr itr itrExpectedContinue id
                if expectedContinue then
                    do wroteContinue <- readItr itr itrWroteContinue id
             do expectedContinue <- readItr itr itrExpectedContinue id
                if expectedContinue then
                    do wroteContinue <- readItr itr itrWroteContinue id


@@ -75,13 +73,12 @@ responseWriter !cnf !h !tQueue !readerTID
                    retry
 
       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
                    retry
 
       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())

-      writeHeaderOrBodyIfNecessary itr
+      writeHeaderOrBodyIfNecessary !itr

           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
           -- 空でなければ、それを出力する。空である時は、もし状態が
           -- Done であれば後処理をする。
           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
           -- 空でなければ、それを出力する。空である時は、もし状態が
           -- Done であれば後処理をする。
           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}

-            itr `seq`

             do wroteHeader <- readItr itr itrWroteHeader id
                
                if not wroteHeader then
             do wroteHeader <- readItr itr itrWroteHeader id
                
                if not wroteHeader then


@@ -100,9 +97,8 @@ responseWriter !cnf !h !tQueue !readerTID
                           return $! writeBodyChunk itr
 
       writeContinue :: Interaction -> IO ()
                           return $! writeBodyChunk itr
 
       writeContinue :: Interaction -> IO ()

-      writeContinue itr
+      writeContinue !itr

           = {-# SCC "writeContinue" #-}
           = {-# SCC "writeContinue" #-}

-            itr `seq`

             do let cont = Response {
                             resVersion = HttpVersion 1 1
                           , resStatus  = Continue
             do let cont = Response {
                             resVersion = HttpVersion 1 1
                           , resStatus  = Continue


@@ -115,9 +111,8 @@ responseWriter !cnf !h !tQueue !readerTID
                awaitSomethingToWrite
 
       writeHeader :: Interaction -> IO ()
                awaitSomethingToWrite
 
       writeHeader :: Interaction -> IO ()

-      writeHeader itr
+      writeHeader !itr

           = {-# SCC "writeHeader" #-}
           = {-# SCC "writeHeader" #-}

-            itr `seq`

             do res <- atomically $! do writeItr itr itrWroteHeader True
                                        readItr itr itrResponse id
                hPutResponse h res
             do res <- atomically $! do writeItr itr itrWroteHeader True
                                        readItr itr itrResponse id
                hPutResponse h res


@@ -125,9 +120,8 @@ responseWriter !cnf !h !tQueue !readerTID
                awaitSomethingToWrite
       
       writeBodyChunk :: Interaction -> IO ()
                awaitSomethingToWrite
       
       writeBodyChunk :: Interaction -> IO ()

-      writeBodyChunk itr
+      writeBodyChunk !itr

           = {-# SCC "writeBodyChunk" #-}
           = {-# SCC "writeBodyChunk" #-}

-            itr `seq`

             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id


@@ -145,18 +139,16 @@ responseWriter !cnf !h !tQueue !readerTID
                awaitSomethingToWrite
 
       finishBodyChunk :: Interaction -> IO ()
                awaitSomethingToWrite
 
       finishBodyChunk :: Interaction -> IO ()

-      finishBodyChunk itr
+      finishBodyChunk !itr

           = {-# SCC "finishBodyChunk" #-}
           = {-# SCC "finishBodyChunk" #-}

-            itr `seq`

             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                when (not willDiscardBody && willChunkBody)
                         $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
 
       finalize :: Interaction -> IO ()
             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                when (not willDiscardBody && willChunkBody)
                         $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
 
       finalize :: Interaction -> IO ()

-      finalize itr
+      finalize !itr

           = {-# SCC "finalize" #-}
           = {-# SCC "finalize" #-}

-            itr `seq`

             do finishBodyChunk itr
                willClose <- atomically $!
                             do queue <- readTVar tQueue
             do finishBodyChunk itr
                willClose <- atomically $!
                             do queue <- readTVar tQueue

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index 608d608169dfa0bdcffbf24a1e600ef6baa8a1c3..5b0ce579ed66e41bc0c1e1d926588743e05468ae 100644 (file)
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -64,7 +64,7 @@ handleStaticFile path
                            $ abort Forbidden [] Nothing
                        -- 讀める
                        tag     <- liftIO $ generateETagFromFile path
                            $ abort Forbidden [] Nothing
                        -- 讀める
                        tag     <- liftIO $ generateETagFromFile path

-                       lastMod <- return $ posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
+                       let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat

                        foundEntity tag lastMod
 
                        -- MIME Type を推定
                        foundEntity tag lastMod
 
                        -- MIME Type を推定


@@ -74,7 +74,7 @@ handleStaticFile path
                          Just mime -> setContentType mime
 
                        -- 實際にファイルを讀んで送る
                          Just mime -> setContentType mime
 
                        -- 實際にファイルを讀んで送る

-                       (liftIO $ B.readFile path) >>= outputLBS
+                       liftIO (B.readFile path) >>= outputLBS

                   else
                     abort Forbidden [] Nothing
            else
                   else
                     abort Forbidden [] Nothing
            else

diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index 6b749a80c8aefb448be43b06908961713ba428c1..9212747d9cf4ea782491240f1c8e201c29715dc4 100644 (file)
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -19,7 +19,7 @@ import Prelude hiding (last)
 splitBy :: (a -> Bool) -> [a] -> [[a]]
 splitBy isSep src
     = case break isSep src
 splitBy :: (a -> Bool) -> [a] -> [[a]]
 splitBy isSep src
     = case break isSep src

-      of (last , []       ) -> last  : []
+      of (last , []       ) -> [last]

          (first, _sep:rest) -> first : splitBy isSep rest
 
 -- |> joinWith ":" ["ab", "c", "def"]
          (first, _sep:rest) -> first : splitBy isSep rest
 
 -- |> joinWith ":" ["ab", "c", "def"]

diff --git a/cabal-package.mk b/cabal-package.mk
index ca291ff93111587ba2f4d30245a97c94713e84a3..d8bbaad16ee155ad694cb2b90652a37fdb10636e 100644 (file)
--- a/cabal-package.mk
+++ b/cabal-package.mk
@@ -13,6 +13,7 @@ FIND     ?= find
 RM_RF    ?= rm -rf
 SUDO     ?= sudo
 AUTOCONF ?= autoconf
 RM_RF    ?= rm -rf
 SUDO     ?= sudo
 AUTOCONF ?= autoconf

+HLINT    ?= hlint

 
 CONFIGURE_ARGS ?= --disable-optimization
 
 
 CONFIGURE_ARGS ?= --disable-optimization
 


@@ -86,4 +87,9 @@ sdist: setup-config
 test: build
        ./Setup test
 
 test: build
        ./Setup test
 

-.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test
+lint:
+       $(HLINT) . --report \
+               --ignore="Use string literal" \
+               --ignore="Use concatMap"
+
+.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test lint