Permalink
Browse files

move repository

  • Loading branch information...
1 parent feb498a commit 38811c6652d6b9003f6f2809f8bb2bd7ead2f7d1 @tanakh tanakh committed Nov 27, 2011
View
@@ -0,0 +1,7 @@
+*~
+*#
+*.o
+*.hi
+*.a
+cabal-dev/
+dist/
View
@@ -0,0 +1,30 @@
+Copyright (c)2011, Hideyuki Tanaka
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Hideyuki Tanaka nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@@ -0,0 +1,9 @@
+module Language.MessagePack.IDL (
+ module Language.MessagePack.IDL.Syntax,
+ module Language.MessagePack.IDL.Parser,
+ module Language.MessagePack.IDL.CodeGen.Haskell,
+ ) where
+
+import Language.MessagePack.IDL.Syntax
+import Language.MessagePack.IDL.Parser
+import Language.MessagePack.IDL.CodeGen.Haskell
@@ -0,0 +1,9 @@
+module Language.MessagePack.IDL.Check (
+ check,
+ ) where
+
+import Language.MessagePack.IDL.Syntax
+
+-- TODO: Implement it!
+check :: Spec -> Bool
+check _ = True
@@ -0,0 +1,226 @@
+{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}
+
+module Language.MessagePack.IDL.CodeGen.Cpp (
+ Config(..),
+ generate,
+ ) where
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.IO as LT
+import System.FilePath
+import Text.Shakespeare.Text
+
+import Language.MessagePack.IDL.Syntax
+
+data Config
+ = Config
+ { configFilePath :: FilePath
+ , configNameSpace :: String
+ }
+ deriving (Show, Eq)
+
+generate:: Config -> Spec -> IO ()
+generate Config {..} spec = do
+ let name = takeBaseName configFilePath
+ once = map toUpper name
+ ns = LT.splitOn "::" $ LT.pack configNameSpace
+ LT.writeFile "types.hpp" $ templ configFilePath once "TYPES" [lt|
+#include <vector>
+#include <map>
+#include <string>
+#include <stdexcept>
+#include <stdint.h>
+#include <msgpack.hpp>
+
+#{genNameSpace ns $ LT.concat $ map (genTypeDecl name) spec }
+|]
+
+ LT.writeFile "server.hpp" $ templ configFilePath once "SERVER" [lt|
+#include "types.hpp"
+#include <msgpack/rpc/server.h>
+
+#{genNameSpace (snoc ns "server") $ LT.concat $ map genServer spec}
+|]
+
+ LT.writeFile "client.hpp" [lt|
+#include "types.hpp"
+#include <msgpack/rpc/client.h>
+
+#{genNameSpace (snoc ns "client") $ LT.concat $ map genClient spec}
+|]
+
+genTypeDecl :: String -> Decl -> LT.Text
+genTypeDecl _ MPMessage {..} =
+ genMsg msgName msgFields False
+
+genTypeDecl _ MPException {..} =
+ genMsg excName excFields True
+
+genTypeDecl _ MPType { .. } =
+ [lt|
+typedef #{genType tyType} #{tyName};
+|]
+
+genTypeDecl _ _ = ""
+
+genMsg name flds isExc =
+ let fields = map f flds
+ fs = map (maybe undefined fldName) $ sortField flds
+ in [lt|
+struct #{name}#{e} {
+public:
+
+ #{destructor}
+ MSGPACK_DEFINE(#{T.intercalate ", " fs});
+#{LT.concat fields}
+};
+|]
+ where
+ e = if isExc then [lt| : public std::exception|] else ""
+ destructor = if isExc then [lt|~#{name}() throw() {}
+|] else ""
+
+ f Field {..} = [lt|
+ #{genType fldType} #{fldName};|]
+
+sortField flds =
+ flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix ->
+ find ((==ix). fldId) flds
+
+genServer :: Decl -> LT.Text
+genServer MPService {..} = [lt|
+template <class Impl>
+class #{serviceName} : public msgpack::rpc::server::base {
+public:
+
+ void dispatch(msgpack::rpc::request req) {
+ try {
+ std::string method;
+ req.method().convert(&method);
+#{LT.concat $ map genMethodDispatch serviceMethods}
+ } catch (const msgpack::type_error& e) {
+ req.error(msgpack::rpc::ARGUMENT_ERROR);
+ } catch (const std::exception& e) {
+ req.error(std::string(e.what()));
+ }
+ }
+};
+|]
+ where
+ genMethodDispatch Function {..} =
+ -- TODO: FIX IT!
+ let typs = map (genType . maybe TVoid fldType) $ sortField methodArgs in
+ let params = map g methodArgs in
+ case params of
+ [] -> [lt|
+ if (method == "#{methodName}") {
+ req.result<#{genType methodRetType}>(static_cast<Impl*>(this)->#{methodName}());
+ return;
+ }
+|]
+ _ -> [lt|
+ if (method == "#{methodName}") {
+ msgpack::type::tuple<#{LT.intercalate ", " typs} > params;
+ req.params().convert(&params);
+ req.result<#{genType methodRetType}>(static_cast<Impl*>(this)->#{methodName}(#{LT.intercalate ", " params}));
+ return;
+ }
+|]
+ where
+ g fld = [lt|params.get<#{show $ fldId fld}>()|]
+
+ genMethodDispatch _ = ""
+
+genServer _ = ""
+
+genClient :: Decl -> LT.Text
+genClient MPService {..} = [lt|
+class #{serviceName} {
+public:
+ #{serviceName}(const std::string &host, uint64_t port)
+ : c_(host, port) {}
+#{LT.concat $ map genMethodCall serviceMethods}
+private:
+ msgpack::rpc::client c_;
+};
+|]
+ where
+ genMethodCall Function {..} =
+ let args = LT.intercalate ", " $ map arg methodArgs in
+ let vals = LT.concat $ map val methodArgs in
+ case methodRetType of
+ TVoid -> [lt|
+ void #{methodName}(#{args}) {
+ c_.call("#{methodName}"#{vals});
+ }
+|]
+ _ -> [lt|
+ #{genType methodRetType } #{methodName}(#{args}) {
+ return c_.call("#{methodName}"#{vals}).get<#{genType methodRetType} >();
+ }
+|]
+ where
+ arg Field {..} = [lt|#{genType fldType} #{fldName}|]
+ val Field {..} = [lt|, #{fldName}|]
+
+ genMethodCall _ = ""
+
+genClient _ = ""
+
+genType :: Type -> LT.Text
+genType (TInt sign bits) =
+ let base = if sign then "int" else "uint" :: LT.Text in
+ [lt|#{base}#{show bits}_t|]
+genType (TFloat False) =
+ [lt|float|]
+genType (TFloat True) =
+ [lt|double|]
+genType TBool =
+ [lt|bool|]
+genType TRaw =
+ [lt|std::string|]
+genType TString =
+ [lt|std::string|]
+genType (TList typ) =
+ [lt|std::vector<#{genType typ} >|]
+genType (TMap typ1 typ2) =
+ [lt|std::map<#{genType typ1}, #{genType typ2} >|]
+genType (TUserDef className params) =
+ [lt|#{className}|]
+genType (TTuple ts) =
+ -- TODO: FIX
+ foldr1 (\t1 t2 -> [lt|std::pair<#{t1}, #{t2} >|]) $ map genType ts
+genType TObject =
+ [lt|msgpack::object|]
+genType TVoid =
+ [lt|void|]
+
+templ :: FilePath -> String -> String -> LT.Text -> LT.Text
+templ filepath once name content = [lt|
+// This file is auto-generated from #{filepath}
+// *** DO NOT EDIT ***
+
+#ifndef #{once}_#{name}_HPP_
+#define #{once}_#{name}_HPP_
+
+#{content}
+
+#endif // #{once}_#{name}_HPP_
+|]
+
+genNameSpace :: [LT.Text] -> LT.Text -> LT.Text
+genNameSpace namespace content = f namespace
+ where
+ f [] = [lt|#{content}|]
+ f (n:ns) = [lt|
+namespace #{n} {
+#{f ns}
+} // namespace #{n}
+|]
+
+snoc xs x = xs ++ [x]
Oops, something went wrong.

0 comments on commit 38811c6

Please sign in to comment.