From: Bryan Duxbury <bryanduxbury@apache.org>
Date: Mon, 20 Sep 2010 15:21:37 +0000 (+0000)
Subject: THRIFT-901. hs: Allow the bindings to compile without -fglasgow-exts and with -Wall... 
X-Git-Tag: 0.5.0~35
X-Git-Url: https://source.supwisdom.com/gerrit/gitweb?a=commitdiff_plain;h=e59a80fbf9d3be9eab5353355718fbd495fad0f1;p=common%2Fthrift.git

THRIFT-901. hs: Allow the bindings to compile without -fglasgow-exts and with -Wall -Werror

This patch makes the bindings compile with pedantic warning levels, and individually declares each required language extension.

Patch: Christian Lavoie

git-svn-id: https://svn.apache.org/repos/asf/incubator/thrift/trunk@998955 13f79535-47bb-0310-9956-ffa450edef68
---

diff --git a/compiler/cpp/src/generate/t_hs_generator.cc b/compiler/cpp/src/generate/t_hs_generator.cc
index c71a1744..4ddd8cde 100644
--- a/compiler/cpp/src/generate/t_hs_generator.cc
+++ b/compiler/cpp/src/generate/t_hs_generator.cc
@@ -200,7 +200,11 @@ void t_hs_generator::init_generator() {
 }
 
 string t_hs_generator::hs_language_pragma() {
-  return std::string("{-# LANGUAGE DeriveDataTypeable #-}");
+  return std::string("{-# LANGUAGE DeriveDataTypeable #-}\n"
+                     "{-# OPTIONS_GHC -fno-warn-missing-signatures #-}\n"
+                     "{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\n"
+                     "{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n"
+                     "{-# OPTIONS_GHC -fno-warn-unused-matches #-}\n");
 }
 
 /**
@@ -712,6 +716,10 @@ void t_hs_generator::generate_hs_function_helpers(t_function* tfunction) {
 void t_hs_generator::generate_service_interface(t_service* tservice) {
   string f_iface_name = get_out_dir()+capitalize(service_name_)+"_Iface.hs";
   f_iface_.open(f_iface_name.c_str());
+  f_iface_ <<
+      hs_language_pragma() << endl <<
+      hs_autogen_comment() << endl;
+
   indent(f_iface_) << "module " << capitalize(service_name_) << "_Iface where" << endl;
 
   indent(f_iface_) <<
@@ -749,6 +757,9 @@ void t_hs_generator::generate_service_interface(t_service* tservice) {
 void t_hs_generator::generate_service_client(t_service* tservice) {
   string f_client_name = get_out_dir()+capitalize(service_name_)+"_Client.hs";
   f_client_.open(f_client_name.c_str());
+  f_client_ <<
+      hs_language_pragma() << endl <<
+      hs_autogen_comment() << endl;
 
   vector<t_function*> functions = tservice->get_functions();
   vector<t_function*>::const_iterator f_iter;
diff --git a/lib/hs/src/Thrift.hs b/lib/hs/src/Thrift.hs
index 291bcae5..182df3fe 100644
--- a/lib/hs/src/Thrift.hs
+++ b/lib/hs/src/Thrift.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
 --
 -- Licensed to the Apache Software Foundation (ASF) under one
 -- or more contributor license agreements. See the NOTICE file
@@ -56,6 +59,7 @@ instance Enum AppExnType where
     toEnum 3 = AE_WRONG_METHOD_NAME
     toEnum 4 = AE_BAD_SEQUENCE_ID
     toEnum 5 = AE_MISSING_RESULT
+    toEnum t = error $ "Invalid AppExnType " ++ show t
 
     fromEnum AE_UNKNOWN = 0
     fromEnum AE_UNKNOWN_METHOD = 1
@@ -85,16 +89,17 @@ writeAppExn pt ae = do
 
 readAppExn :: (Protocol p, Transport t) => p t -> IO AppExn
 readAppExn pt = do
-    readStructBegin pt
+    _ <- readStructBegin pt
     rec <- readAppExnFields pt (AppExn {ae_type = undefined, ae_message = undefined})
     readStructEnd pt
     return rec
 
+readAppExnFields :: forall (a :: * -> *) t. (Protocol a, Transport t) => a t -> AppExn -> IO AppExn 
 readAppExnFields pt rec = do
-    (n, ft, id) <- readFieldBegin pt
+    (_, ft, tag) <- readFieldBegin pt
     if ft == T_STOP
         then return rec
-        else case id of
+        else case tag of
                  1 -> if ft == T_STRING then
                           do s <- readString pt
                              readAppExnFields pt rec{ae_message = s}
diff --git a/lib/hs/src/Thrift/Protocol.hs b/lib/hs/src/Thrift/Protocol.hs
index 8fa060ea..c7c2d693 100644
--- a/lib/hs/src/Thrift/Protocol.hs
+++ b/lib/hs/src/Thrift/Protocol.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 --
 -- Licensed to the Apache Software Foundation (ASF) under one
 -- or more contributor license agreements. See the NOTICE file
@@ -79,6 +80,7 @@ instance Enum ThriftType where
     toEnum 13 = T_MAP
     toEnum 14 = T_SET
     toEnum 15 = T_LIST
+    toEnum t = error $ "Invalid ThriftType " ++ show t
 
 data MessageType
     = M_CALL
@@ -94,6 +96,7 @@ instance Enum MessageType where
     toEnum 1 = M_CALL
     toEnum 2 = M_REPLY
     toEnum 3 = M_EXCEPTION
+    toEnum t = error $ "Invalid MessageType " ++ show t
 
 
 class Protocol a where
@@ -149,8 +152,8 @@ class Protocol a where
 
 
 skip :: (Protocol p, Transport t) => p t -> ThriftType -> IO ()
-skip p T_STOP = return ()
-skip p T_VOID = return ()
+skip _ T_STOP = return ()
+skip _ T_VOID = return ()
 skip p T_BOOL = readBool p >> return ()
 skip p T_BYTE = readByte p >> return ()
 skip p T_I16 = readI16 p >> return ()
@@ -158,7 +161,7 @@ skip p T_I32 = readI32 p >> return ()
 skip p T_I64 = readI64 p >> return ()
 skip p T_DOUBLE = readDouble p >> return ()
 skip p T_STRING = readString p >> return ()
-skip p T_STRUCT = do readStructBegin p
+skip p T_STRUCT = do _ <- readStructBegin p
                      skipFields p
                      readStructEnd p
 skip p T_MAP = do (k, v, s) <- readMapBegin p
diff --git a/lib/hs/src/Thrift/Protocol/Binary.hs b/lib/hs/src/Thrift/Protocol/Binary.hs
index fa9a2079..308ab48d 100644
--- a/lib/hs/src/Thrift/Protocol/Binary.hs
+++ b/lib/hs/src/Thrift/Protocol/Binary.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MagicHash #-}
 --
 -- Licensed to the Apache Software Foundation (ASF) under one
 -- or more contributor license agreements. See the NOTICE file
@@ -37,7 +39,10 @@ import Thrift.Transport
 
 import qualified Data.ByteString.Lazy.Char8 as LBS
 
+version_mask :: Int
 version_mask = 0xffff0000
+
+version_1 :: Int
 version_1    = 0x80010000
 
 data BinaryProtocol a = Transport a => BinaryProtocol a
@@ -58,7 +63,7 @@ instance Protocol BinaryProtocol where
     writeFieldEnd _ = return ()
     writeFieldStop p = writeType p T_STOP
     writeMapBegin p (k, v, n) = writeType p k >> writeType p v >> writeI32 p n
-    writeMapEnd p = return ()
+    writeMapEnd _ = return ()
     writeListBegin p (t, n) = writeType p t >> writeI32 p n
     writeListEnd _ = return ()
     writeSetBegin p (t, n) = writeType p t >> writeI32 p n
@@ -141,7 +146,7 @@ getByte :: Bits a => a -> Int -> a
 getByte i n = 255 .&. (i `shiftR` (8 * n))
 
 getBytes :: (Bits a, Integral a) => a -> Int -> LBS.ByteString
-getBytes i 0 = LBS.empty
+getBytes _ 0 = LBS.empty
 getBytes i n = (toEnum $ fromIntegral $ getByte i (n-1)) `LBS.cons` (getBytes i (n-1))
 
 floatBits :: Double -> Word64
diff --git a/lib/hs/src/Thrift/Server.hs b/lib/hs/src/Thrift/Server.hs
index 770965f1..4634a6bd 100644
--- a/lib/hs/src/Thrift/Server.hs
+++ b/lib/hs/src/Thrift/Server.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 --
 -- Licensed to the Apache Software Foundation (ASF) under one
 -- or more contributor license agreements. See the NOTICE file
@@ -31,7 +32,7 @@ import Network
 import System.IO
 
 import Thrift
-import Thrift.Transport.Handle
+import Thrift.Transport.Handle()
 import Thrift.Protocol.Binary
 
 
@@ -60,6 +61,6 @@ runBasicServer hand proc port = runThreadedServer binaryAccept hand proc (PortNu
 acceptLoop :: IO t -> (t -> IO Bool) -> IO a
 acceptLoop accepter proc = forever $
     do ps <- accepter
-       forkIO $ handle (\(e :: SomeException) -> return ())
+       forkIO $ handle (\(_ :: SomeException) -> return ())
                   (loop $ proc ps)
   where loop m = do { continue <- m; when continue (loop m) }
diff --git a/lib/hs/src/Thrift/Transport.hs b/lib/hs/src/Thrift/Transport.hs
index 80e4914d..99dbd6f1 100644
--- a/lib/hs/src/Thrift/Transport.hs
+++ b/lib/hs/src/Thrift/Transport.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 --
 -- Licensed to the Apache Software Foundation (ASF) under one
 -- or more contributor license agreements. See the NOTICE file
@@ -39,7 +40,7 @@ class Transport a where
     tFlush  :: a -> IO ()
     tReadAll :: a -> Int -> IO LBS.ByteString
 
-    tReadAll a 0 = return mempty
+    tReadAll _ 0 = return mempty
     tReadAll a len = do
         result <- tRead a len
         let rlen = fromIntegral $ LBS.length result
diff --git a/lib/hs/src/Thrift/Transport/Handle.hs b/lib/hs/src/Thrift/Transport/Handle.hs
index 0b1cb75a..e9fe17eb 100644
--- a/lib/hs/src/Thrift/Transport/Handle.hs
+++ b/lib/hs/src/Thrift/Transport/Handle.hs
@@ -1,3 +1,8 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 --
 -- Licensed to the Apache Software Foundation (ASF) under one
 -- or more contributor license agreements. See the NOTICE file
@@ -23,7 +28,7 @@ module Thrift.Transport.Handle
     ) where
 
 import Control.Exception ( throw )
-import Control.Monad ( replicateM )
+import Control.Monad ()
 
 import Network
 
@@ -55,6 +60,7 @@ instance HandleSource (HostName, PortID) where
     hOpen = uncurry connectTo
 
 
+handleEOF :: forall a (m :: * -> *).(Monoid a, Monad m) => IOError -> m a
 handleEOF e = if isEOFError e
     then return mempty
     else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN
diff --git a/lib/hs/src/Thrift/Transport/HttpClient.hs b/lib/hs/src/Thrift/Transport/HttpClient.hs
index 22682618..6729b12b 100644
--- a/lib/hs/src/Thrift/Transport/HttpClient.hs
+++ b/lib/hs/src/Thrift/Transport/HttpClient.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 --
 -- Licensed to the Apache Software Foundation (ASF) under one
 -- or more contributor license agreements. See the NOTICE file
@@ -26,7 +27,6 @@ module Thrift.Transport.HttpClient
 import Thrift.Transport
 import Network.URI
 import Network.HTTP hiding (port, host)
-import Network.TCP
 
 import Control.Monad (liftM)
 import Data.Maybe (fromJust)
@@ -47,26 +47,29 @@ data HttpClient =
       readBuffer :: ReadBuffer
     }
 
+uriAuth :: URI -> URIAuth
 uriAuth = fromJust . uriAuthority
+
+host :: URI -> String
 host = uriRegName . uriAuth
 
 port :: URI -> Int
-port uri =
+port uri_ =
     if portStr == mempty then
         httpPort
     else
         read portStr
     where
-      portStr = dropWhile (== ':') $ uriPort $ uriAuth uri
+      portStr = dropWhile (== ':') $ uriPort $ uriAuth uri_
       httpPort = 80
 
 -- | Use 'openHttpClient' to create an HttpClient connected to @uri@
 openHttpClient :: URI -> IO HttpClient
-openHttpClient uri = do
-  stream <- openTCPConnection (host uri) (port uri)
+openHttpClient uri_ = do
+  stream <- openTCPConnection (host uri_) (port uri_)
   wbuf <- newWriteBuffer
   rbuf <- newReadBuffer
-  return $ HttpClient stream uri wbuf rbuf
+  return $ HttpClient stream uri_ wbuf rbuf
 
 instance Transport HttpClient where
 
@@ -89,8 +92,8 @@ instance Transport HttpClient where
 
       res <- sendHTTP (hstream hclient) request
       case res of
-        Right res -> do
-            fillBuf (readBuffer hclient) (rspBody res)
+        Right response -> do
+            fillBuf (readBuffer hclient) (rspBody response)
         Left _ -> do
             throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN
       return ()