From: David Reiss <dreiss@apache.org>
Date: Mon, 11 Jan 2010 19:12:56 +0000 (+0000)
Subject: THRIFT-560. haskell: Move to ByteString and compiler fixes
X-Git-Tag: 0.3.0~143
X-Git-Url: https://source.supwisdom.com/gerrit/gitweb?a=commitdiff_plain;h=752529e9b449f69d2fce19eba1c12471858279b9;p=common%2Fthrift.git

THRIFT-560. haskell: Move to ByteString and compiler fixes

git-svn-id: https://svn.apache.org/repos/asf/incubator/thrift/trunk@898012 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 c8fda774..7fce44de 100644
--- a/compiler/cpp/src/generate/t_hs_generator.cc
+++ b/compiler/cpp/src/generate/t_hs_generator.cc
@@ -139,8 +139,9 @@ class t_hs_generator : public t_oop_generator {
    */
 
   std::string hs_autogen_comment();
+  std::string hs_language_pragma();
   std::string hs_imports();
-  std::string type_name(t_type* ttype);
+  std::string type_name(t_type* ttype, string function_prefix = "");
   std::string function_type(t_function* tfunc, bool options = false, bool io = false, bool method = false);
   std::string type_to_enum(t_type* ttype);
   std::string render_hs_type(t_type* type, bool needs_parens = true);
@@ -180,13 +181,17 @@ void t_hs_generator::init_generator() {
   string f_consts_name = get_out_dir()+pname+"_Consts.hs";
   f_consts_.open(f_consts_name.c_str());
 
+
+
   // Print header
   f_types_ <<
+    hs_language_pragma() << endl <<
     hs_autogen_comment() << endl <<
     "module " << pname <<"_Types where" << endl <<
     hs_imports() << endl;
 
   f_consts_ <<
+    hs_language_pragma() << endl <<
     hs_autogen_comment() << endl <<
     "module " << pname <<"_Consts where" << endl <<
     hs_imports() << endl <<
@@ -194,6 +199,9 @@ void t_hs_generator::init_generator() {
 
 }
 
+string t_hs_generator::hs_language_pragma() {
+  return std::string("{-# LANGUAGE DeriveDataTypeable #-}");
+}
 
 /**
  * Autogen'd comment
@@ -211,7 +219,17 @@ string t_hs_generator::hs_autogen_comment() {
  * Prints standard thrift imports
  */
 string t_hs_generator::hs_imports() {
-  return "import Thrift\nimport Data.Typeable ( Typeable )\nimport Control.Exception\nimport qualified Data.Map as Map\nimport qualified Data.Set as Set\nimport Data.Int";
+  const vector<t_program*>& includes = program_->get_includes();
+  string result = "";
+  for (size_t i = 0; i < includes.size(); ++i) {
+    result += "import qualified " + capitalize(includes[i]->get_name()) + "_Types\n";
+  }
+  if (includes.size() > 0) {
+    result += "\n";
+  }
+
+  result += "import Thrift\nimport Data.Typeable ( Typeable )\nimport Control.Exception\nimport qualified Data.Map as Map\nimport qualified Data.Set as Set\nimport Data.Int;\nimport Prelude ((==), String, Eq, Show, Ord, Maybe(..), (&&), (||), return, IO, Enum, fromEnum, toEnum, Bool(..), (++))";
+  return result;
 }
 
 /**
@@ -618,6 +636,7 @@ void t_hs_generator::generate_service(t_service* tservice) {
   f_service_.open(f_service_name.c_str());
 
   f_service_ <<
+    hs_language_pragma() << endl <<
     hs_autogen_comment() << endl <<
     "module " << capitalize(service_name_) << " where" << endl <<
     hs_imports() << endl;
@@ -1249,7 +1268,7 @@ void t_hs_generator::generate_serialize_field(ofstream &out,
 void t_hs_generator::generate_serialize_struct(ofstream &out,
                                                t_struct* tstruct,
                                                string prefix) {
-  out << "write_" << type_name(tstruct) << " oprot " << prefix;
+  out << type_name(tstruct, "write_") << " oprot " << prefix;
 }
 
 void t_hs_generator::generate_serialize_container(ofstream &out,
@@ -1332,7 +1351,7 @@ string t_hs_generator::function_type(t_function* tfunc, bool options, bool io, b
 }
 
 
-string t_hs_generator::type_name(t_type* ttype) {
+string t_hs_generator::type_name(t_type* ttype, string function_prefix) {
   string prefix = "";
   t_program* program = ttype->get_program();
   if (program != NULL && program != program_) {
@@ -1347,7 +1366,7 @@ string t_hs_generator::type_name(t_type* ttype) {
   } else {
     name = capitalize(name);
   }
-  return prefix + name;
+  return prefix + function_prefix + name;
 }
 
 /**
diff --git a/lib/hs/Thrift.cabal b/lib/hs/Thrift.cabal
index 4cef4de6..8132069b 100644
--- a/lib/hs/Thrift.cabal
+++ b/lib/hs/Thrift.cabal
@@ -1,5 +1,5 @@
 Name:           Thrift
-Version:        0.1.0
+Version:        0.1.1
 Cabal-Version:  >= 1.2
 License:        Apache2
 Category:       Foreign
@@ -10,11 +10,11 @@ Library
   Hs-Source-Dirs:
     src
   Build-Depends:
-    base >=4, network, ghc-prim
+    base >=4, network, ghc-prim, binary, bytestring, HTTP
   ghc-options:
     -fglasgow-exts
   Extensions:
     DeriveDataTypeable
   Exposed-Modules:
     Thrift, Thrift.Protocol, Thrift.Transport, Thrift.Protocol.Binary
-    Thrift.Transport.Handle, Thrift.Server
+    Thrift.Transport.Handle, Thrift.Transport.HttpClient,  Thrift.Server
diff --git a/lib/hs/src/Thrift/Protocol/Binary.hs b/lib/hs/src/Thrift/Protocol/Binary.hs
index 3f798cee..fa9a2079 100644
--- a/lib/hs/src/Thrift/Protocol/Binary.hs
+++ b/lib/hs/src/Thrift/Protocol/Binary.hs
@@ -23,6 +23,7 @@ module Thrift.Protocol.Binary
     ) where
 
 import Control.Exception ( throw )
+import Control.Monad ( liftM )
 
 import Data.Bits
 import Data.Int
@@ -34,6 +35,7 @@ import GHC.Word
 import Thrift.Protocol
 import Thrift.Transport
 
+import qualified Data.ByteString.Lazy.Char8 as LBS
 
 version_mask = 0xffff0000
 version_1    = 0x80010000
@@ -62,13 +64,13 @@ instance Protocol BinaryProtocol where
     writeSetBegin p (t, n) = writeType p t >> writeI32 p n
     writeSetEnd _ = return ()
 
-    writeBool p b = tWrite (getTransport p) [toEnum $ if b then 1 else 0]
+    writeBool p b = tWrite (getTransport p) $ LBS.singleton $ toEnum $ if b then 1 else 0
     writeByte p b = tWrite (getTransport p) (getBytes b 1)
     writeI16 p b = tWrite (getTransport p) (getBytes b 2)
     writeI32 p b = tWrite (getTransport p) (getBytes b 4)
     writeI64 p b = tWrite (getTransport p) (getBytes b 8)
     writeDouble p d = writeI64 p (fromIntegral $ floatBits d)
-    writeString p s = writeI32 p (length s) >> tWrite (getTransport p) s
+    writeString p s = writeI32 p (length s) >> tWrite (getTransport p) (LBS.pack s)
     writeBinary = writeString
 
     readMessageBegin p = do
@@ -116,7 +118,10 @@ instance Protocol BinaryProtocol where
     readDouble p = do
         bs <- readI64 p
         return $ floatOfBits $ fromIntegral bs
-    readString p = readI32 p >>= tReadAll (getTransport p)
+    readString p = do
+        i <- readI32 p
+        LBS.unpack `liftM` tReadAll (getTransport p) i
+
     readBinary = readString
 
 
@@ -128,16 +133,16 @@ writeType p t = writeByte p (fromEnum t)
 readType :: (Protocol p, Transport t) => p t -> IO ThriftType
 readType p = toEnum `fmap` readByte p
 
-composeBytes :: (Bits b, Enum t) => [t] -> b
-composeBytes = (foldl' fn 0) . (map $ fromIntegral . fromEnum)
+composeBytes :: (Bits b) => LBS.ByteString -> b
+composeBytes = (foldl' fn 0) . (map (fromIntegral . fromEnum)) . LBS.unpack
     where fn acc b = (acc `shiftL` 8) .|. b
 
 getByte :: Bits a => a -> Int -> a
 getByte i n = 255 .&. (i `shiftR` (8 * n))
 
-getBytes :: (Bits a, Integral a) => a -> Int -> String
-getBytes i 0 = []
-getBytes i n = (toEnum $ fromIntegral $ getByte i (n-1)):(getBytes i (n-1))
+getBytes :: (Bits a, Integral a) => a -> Int -> LBS.ByteString
+getBytes i 0 = LBS.empty
+getBytes i n = (toEnum $ fromIntegral $ getByte i (n-1)) `LBS.cons` (getBytes i (n-1))
 
 floatBits :: Double -> Word64
 floatBits (D# d#) = W64# (unsafeCoerce# d#)
diff --git a/lib/hs/src/Thrift/Transport.hs b/lib/hs/src/Thrift/Transport.hs
index 29f50d07..80e4914d 100644
--- a/lib/hs/src/Thrift/Transport.hs
+++ b/lib/hs/src/Thrift/Transport.hs
@@ -28,23 +28,25 @@ import Control.Exception ( Exception, throw )
 
 import Data.Typeable ( Typeable )
 
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Monoid
 
 class Transport a where
     tIsOpen :: a -> IO Bool
     tClose  :: a -> IO ()
-    tRead   :: a -> Int -> IO String
-    tWrite  :: a -> String ->IO ()
+    tRead   :: a -> Int -> IO LBS.ByteString
+    tWrite  :: a -> LBS.ByteString -> IO ()
     tFlush  :: a -> IO ()
-    tReadAll :: a -> Int -> IO String
+    tReadAll :: a -> Int -> IO LBS.ByteString
 
-    tReadAll a 0 = return []
+    tReadAll a 0 = return mempty
     tReadAll a len = do
         result <- tRead a len
-        let rlen = length result
+        let rlen = fromIntegral $ LBS.length result
         when (rlen == 0) (throw $ TransportExn "Cannot read. Remote side has closed." TE_UNKNOWN)
         if len <= rlen
             then return result
-            else (result ++) `fmap` (tReadAll a (len - rlen))
+            else (result `mappend`) `fmap` (tReadAll a (len - rlen))
 
 data TransportExn = TransportExn String TransportExnType
   deriving ( Show, Typeable )
diff --git a/lib/hs/src/Thrift/Transport/Handle.hs b/lib/hs/src/Thrift/Transport/Handle.hs
index e49456b5..0b1cb75a 100644
--- a/lib/hs/src/Thrift/Transport/Handle.hs
+++ b/lib/hs/src/Thrift/Transport/Handle.hs
@@ -32,12 +32,14 @@ import System.IO.Error ( isEOFError )
 
 import Thrift.Transport
 
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Monoid
 
 instance Transport Handle where
     tIsOpen = hIsOpen
     tClose h    = hClose h
-    tRead  h n  = replicateM n (hGetChar h) `catch` handleEOF
-    tWrite h s  = mapM_ (hPutChar h) s
+    tRead  h n  = LBS.hGet h n `catch` handleEOF
+    tWrite h s  = LBS.hPut h s
     tFlush = hFlush
 
 
@@ -54,5 +56,5 @@ instance HandleSource (HostName, PortID) where
 
 
 handleEOF e = if isEOFError e
-    then return []
+    then return mempty
     else throw $ TransportExn "TChannelTransport: Could not read" TE_UNKNOWN