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/lib/hs/src/Thrift.hs b/lib/hs/src/Thrift.hs
index 291bcae..182df3f 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 @@
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 @@
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 8fa060e..c7c2d69 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 @@
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 @@
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 @@
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_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 fa9a207..308ab48 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 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 @@
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 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 770965f..4634a6b 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 System.IO
import Thrift
-import Thrift.Transport.Handle
+import Thrift.Transport.Handle()
import Thrift.Protocol.Binary
@@ -60,6 +61,6 @@
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 80e4914..99dbd6f 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 @@
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 0b1cb75..e9fe17e 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 @@
) where
import Control.Exception ( throw )
-import Control.Monad ( replicateM )
+import Control.Monad ()
import Network
@@ -55,6 +60,7 @@
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 2268261..6729b12 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 @@
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 @@
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 @@
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 ()