packages feed

msgpack-idl (empty) → 0.1.0

raw patch · 16 files changed

+1898/−0 lines, 16 filesdep +basedep +blaze-builderdep +bytestringsetup-changed

Dependencies added: base, blaze-builder, bytestring, cmdargs, containers, directory, filepath, msgpack, msgpack-idl, peggy, shakespeare-text, template-haskell, text

Files

+ LICENSE 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.
+ Language/MessagePack/IDL.hs view
@@ -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
+ Language/MessagePack/IDL/Check.hs view
@@ -0,0 +1,9 @@+module Language.MessagePack.IDL.Check (+  check,+  ) where++import Language.MessagePack.IDL.Syntax++-- TODO: Implement it!+check :: Spec -> Bool+check _ = True
+ Language/MessagePack/IDL/CodeGen/Cpp.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}++module Language.MessagePack.IDL.CodeGen.Cpp (+  Config(..),+  generate,+  ) where++import Data.Char+import Data.List+import qualified Data.Text 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+    , configPFICommon :: Bool+    }+  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++      typeHeader+        | configPFICommon =+          [lt|#include <msgpack.hpp>|]+        | otherwise =+          [lt|#include <msgpack.hpp>|]+      serverHeader+        | configPFICommon =+          [lt|#include <pficommon/network/mprpc.h>+#include <pficommon/lang/bind.h>|]+        | otherwise =+          [lt|#include <msgpack/rpc/server.h>|]+      clientHeader+        | configPFICommon =+          [lt|#include <pficommon/network/mprpc.h>|]+        | otherwise =+          [lt|#include <msgpack/rpc/client.h>|]+  +  LT.writeFile (name ++ "_types.hpp") $ templ configFilePath once "TYPES" [lt|+#include <vector>+#include <map>+#include <string>+#include <stdexcept>+#include <stdint.h>+#{typeHeader}++#{genNameSpace ns $ LT.concat $ map (genTypeDecl name) spec }+|]++  LT.writeFile (name ++ "_server.hpp") $ templ configFilePath once "SERVER" [lt|+#include "#{name}_types.hpp"+#{serverHeader}++#{genNameSpace (snoc ns "server") $ LT.concat $ map (genServer configPFICommon) spec}+|]++  LT.writeFile (name ++ "_client.hpp") [lt|+#include "#{name}_types.hpp"+#{clientHeader}++#{genNameSpace (snoc ns "client") $ LT.concat $ map (genClient configPFICommon) 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 :: Bool -> Decl -> LT.Text+genServer False 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 True MPService {..} = [lt|+template <class Impl>+class #{serviceName} : public pfi::network::mprpc::rpc_server {+public:+  #{serviceName}(double timeout_sec): rpc_server(timeout_sec) {+#{LT.concat $ map genSetMethod serviceMethods}+  }+};+|]+  where+    genSetMethod Function {..} =+      let typs = map (genType . maybe TVoid fldType) $ sortField methodArgs+          sign = [lt|#{genType methodRetType}(#{LT.intercalate ", " typs})|]+          phs  = LT.concat $ [[lt|, pfi::lang::_#{show ix}|] | ix <- [1 .. length (typs)]]+      in [lt|+    rpc_server::add<#{sign} >("#{methodName}", pfi::lang::bind(&Impl::#{methodName}, static_cast<Impl*>(this)#{phs}));|]++    genSetMethod _ = ""++genServer _ _ = ""++genClient :: Bool -> Decl -> LT.Text+genClient False 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 True MPService {..} = [lt|+class #{serviceName} : public pfi::network::mprpc::rpc_client {+public:+  #{serviceName}(const std::string &host, uint64_t port, double timeout_sec)+    : rpc_client(host, port, timeout_sec) {}+#{LT.concat $ map genMethodCall serviceMethods}+private:+};+|]+  where+  genMethodCall Function {..} =+    let typs = map (genType . maybe TVoid fldType) $ sortField methodArgs+        sign = [lt|#{genType methodRetType}(#{LT.intercalate ", " typs})|]+        args = LT.intercalate ", " $ map arg methodArgs+        vals = LT.intercalate ", " $ map val methodArgs in+    case methodRetType of+      TVoid -> [lt|+    void #{methodName}(#{args}) {+      call<#{sign}>("#{methodName}")(#{vals});+    }+|]+      _ -> [lt|+    #{genType methodRetType} #{methodName}(#{args}) {+      return call<#{sign}>("#{methodName}")(#{vals});+    }+|]+    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]
+ Language/MessagePack/IDL/CodeGen/Haskell.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Language.MessagePack.IDL.CodeGen.Haskell (+  generate,+  ) where++import Data.Char+import Data.Monoid+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 Language.Haskell.TH as TH+import Text.Shakespeare.Text++import Language.MessagePack.IDL.Syntax as MP++generate = undefined++{-+generate :: FilePath -> String -> Spec -> IO ()+generate filename name spec = do+  LT.writeFile "Types.hs" [lt|+{-# LANGUAGE TemplateHaskell #-}++module Types where++import Data.Int+import Data.MessagePack+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Words+#{LT.concat $ map genTypeDecl spec}+|]++  LT.writeFile "Server.hs" [lt|+|]++  LT.writeFile "Client.hs" [lt|+module Server where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Map (Map)+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T++import qualified Network.MessagePackRpc.Client as MP++import Types+#{LT.concat $ map genClient spec}+|]++genClient :: Decl -> LT.Text+genClient Service {..} =+  [lt|+newtype #{monadName} m a+  = #{monadName} { un#{monadName} :: StateT () m a }+  deriving (Monad, MonadIO, MonadTrans, MonadState ())+#{LT.concat $ map genMethod serviceMethods}+|]+  where+    monadName = classize (serviceName) `mappend` "T"+    genMethod Function {..} =+      let ts = map (genType . fldType) methodArgs in+      let typs = ts ++ [ [lt|#{monadName} (#{genType methodRetType})|] ] in+      [lt|+#{methodize methodName} :: #{LT.intercalate " -> " typs}+#{methodize methodName} = MP.method "#{methodName}"+|]+    genMethod f = error $ "unsupported: " ++ show f++genClient _ = ""++genTypeDecl :: Decl -> LT.Text+genTypeDecl Message {..} =+  let mems = LT.intercalate "\n  , " $ map f msgFields in+  [lt|+data #{dataName}+  = #{dataName}+  { #{mems}+  }+  deriving (Eq, Show)+deriveObject False ''#{dataName}+|]+  where+    dataName = classize msgName+    f Field {..} =+      let fname = uncapital dataName `mappend` (capital $ camelize fldName) in+      [lt|#{fname} :: #{genType fldType}|]++genTypeDecl _ = ""++genType :: Type -> LT.Text+genType (TInt sign bits) =+  let base = if sign then "Int" else "Word" :: T.Text in+  [lt|#{base}#{show bits}|]+genType (TFloat False) =+  [lt|Float|]+genType (TFloat True) =+  [lt|Double|]+genType TBool =+  [lt|Bool|]+genType TRaw =+  [lt|ByteString|]+genType TString =+  [lt|Text|]+genType (TList typ) =+  [lt|[#{genType typ}]|]+genType (TMap typ1 typ2) =+  [lt|Map (#{genType typ1}) (#{genType typ2})|]+genType (TClass name) =+  [lt|#{classize name}|]+genType (TTuple typs) =+  [lt|(#{LT.intercalate ", " $ map genType typs})|]+genType (TVoid) =+  [lt|()|]++classize :: T.Text -> T.Text+classize = capital . camelize++methodize :: T.Text -> T.Text+methodize = uncapital . camelize++camelize :: T.Text -> T.Text+camelize = T.concat . map capital . T.words . T.map ubToSpc where+  ubToSpc '_' = ' '+  ubToSpc c = c++capital :: T.Text -> T.Text+capital word =+  (T.map toUpper $ T.take 1 word) `mappend` T.drop 1 word++uncapital :: T.Text -> T.Text+uncapital word =+  (T.map toLower $ T.take 1 word) `mappend` T.drop 1 word++{-+genServer :: Spec -> IO Builder+genServer = undefined++genClient :: Spec -> IO Builder+genClient spec = do+  decs <- runQ $ genClient' spec+  putStrLn $ pprint decs+  undefined++genClient' :: Spec -> Q [Dec]+genClient' spec = return . concat =<< mapM genDecl spec++genDecl :: Decl -> Q [Dec]+genDecl (Message name super fields) = do+  let clsName = mkName $ T.unpack name+      con = recC clsName $ map genFld fields+  d <- dataD (cxt []) clsName [] [con] [''Eq, ''Ord, ''Show]+  return [d]+  where+    genFld (Field fid req typ fname _) =+      varStrictType (mkName $ uncapital $ T.unpack name ++ capital (T.unpack fname)) (strictType notStrict $ genType typ)++genDecl (Service name version meths) = do+  return []++genDecl _ = do+  d <- dataD (cxt []) (mkName "Ign") [] [] []+  return [d]++genType :: MP.Type -> Q TH.Type+genType (TInt False 8 ) = conT ''Word8+genType (TInt False 16) = conT ''Word16+genType (TInt False 32) = conT ''Word32+genType (TInt False 64) = conT ''Word64+genType (TInt True  8 ) = conT ''Int8+genType (TInt True  16) = conT ''Int16+genType (TInt True  32) = conT ''Int32+genType (TInt True  64) = conT ''Int64++genType (TFloat False) = conT ''Float+genType (TFloat True ) = conT ''Double++genType TBool = conT ''Bool+genType TRaw = conT ''B.ByteString+genType TString = conT ''T.Text++genType (TList typ) =+  listT `appT` genType typ+genType (TMap kt vt) =+  [t| M.Map $(genType kt) $(genType vt) |]++genType (TClass name) =+  conT $ mkName $ capital $ T.unpack name++genType (TTuple typs) =+  foldl appT (tupleT (length typs)) (map genType typs)++genType TVoid =+  tupleT 0++capital (c:cs) = toUpper c : cs+capital cs = cs++uncapital (c:cs) = toLower c : cs+uncapital cs = cs+-}++-}
+ Language/MessagePack/IDL/CodeGen/Java.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}++module Language.MessagePack.IDL.CodeGen.Java (+  Config(..),+  generate,+  ) where++import Data.Char+import Data.Monoid+import qualified Data.Text 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+    , configPackage :: String+    }+  deriving (Show, Eq)++generate :: Config -> Spec -> IO()+generate config spec = do+  let typeAlias = map genAlias $ filter isMPType spec++  genTuple config+  mapM_ (genClient typeAlias config) spec+  mapM_ (genStruct typeAlias $ configPackage config) spec+  mapM_ (genException $ configPackage config) spec++{--+  LT.writeFile (name ++ "Server.java") $ templ (configFilePath ++ configPackage ++"/server/")[lt|+import org.msgpack.rpc.Server;+package #{configPackage}++#{LT.concat $ map genServer spec}+|]+--}++genTuple :: Config -> IO()+genTuple Config {..} = do+  LT.writeFile("Tuple.java") $ templ (configFilePath) [lt|+package #{configPackage};+public class Tuple<T, U> {+  public T a;+  public U b;+};+|]++genImport :: FilePath -> Decl -> LT.Text+genImport packageName MPMessage {..} = +    [lt|import #{packageName}.#{formatClassNameT msgName};+|]+genImport _ _ = ""++genStruct :: [(T.Text, Type)] -> FilePath -> Decl -> IO()+genStruct alias packageName MPMessage {..} = do+  let params = if null msgParam then "" else [lt|<#{T.intercalate ", " msgParam}>|]+      resolvedMsgFields = map (resolveFieldAlias alias) msgFields+  LT.writeFile ( (formatClassName $ T.unpack msgName) ++ ".java") [lt|+package #{packageName};++public class #{formatClassNameT msgName} #{params} {++#{LT.concat $ map genDecl resolvedMsgFields}+  public #{formatClassNameT msgName}() {+  #{LT.concat $ map genInit resolvedMsgFields}+  }+};+|]+genStruct _ _ _ = return ()++resolveMethodAlias :: [(T.Text, Type)] -> Method -> Method+resolveMethodAlias alias Function {..}  = Function methodInherit methodName (resolveTypeAlias alias methodRetType) (map (resolveFieldAlias alias) methodArgs)+resolveMethodAlias _ f = f++resolveFieldAlias :: [(T.Text, Type)] -> Field -> Field+resolveFieldAlias alias Field {..} = Field fldId (resolveTypeAlias alias fldType) fldName fldDefault++resolveTypeAlias :: [(T.Text, Type)] -> Type -> Type+resolveTypeAlias alias ty = let fixedAlias = resolveTypeAlias alias in +                           case ty of+                             TNullable t ->+                                 TNullable $ fixedAlias t+                             TList t ->+                                 TList $ fixedAlias t+                             TMap s t ->+                                 TMap (fixedAlias s) (fixedAlias t)+                             TTuple ts ->+                                 TTuple $ map fixedAlias ts+                             TUserDef className params ->+                                 case lookup className alias of +                                   Just resolvedType -> resolvedType+                                   Nothing -> TUserDef className (map fixedAlias params)+                             otherwise -> ty++genInit :: Field -> LT.Text+genInit Field {..} = case fldDefault of+                      Nothing -> ""+                      Just defaultVal -> [lt| #{fldName} = #{genLiteral defaultVal};|]++genDecl :: Field -> LT.Text+genDecl Field {..} = +    [lt|  public #{genType fldType} #{fldName};+|]++genException :: FilePath -> Decl -> IO()+genException packageName MPException {..} = do+  LT.writeFile ( (formatClassName $ T.unpack excName) ++ ".java") [lt|+package #{packageName};++public class #{formatClassNameT excName} #{params}{++#{LT.concat $ map genDecl excFields}+  public #{formatClassNameT excName}() {+  #{LT.concat $ map genInit excFields}+  }+};+|]+  where+    params = if null excParam then "" else [lt|<#{T.intercalate ", " excParam}>|]+    super = case excSuper of +              Just x -> [st|extends #{x}|]+              Nothing -> ""+genException _ _ = return ()++genClient :: [(T.Text, Type)] -> Config -> Decl -> IO()+genClient alias Config {..} MPService {..} = do +  let resolvedServiceMethods = map (resolveMethodAlias alias) serviceMethods+  LT.writeFile (T.unpack className ++ ".java") $ templ configFilePath [lt|++package #{configPackage};+import java.util.ArrayList;+import org.msgpack.rpc.Client;+import org.msgpack.rpc.loop.EventLoop;++public class #{className} {+  public #{className}(String host, int port, double timeout_sec) throws Exception {+    EventLoop loop = EventLoop.defaultEventLoop();+    c_ = new Client(host, port, loop);+    iface_ = c_.proxy(RPCInterface.class);+  }++  public static interface RPCInterface {+#{LT.concat $ map genSignature resolvedServiceMethods}+  }++#{LT.concat $ map genMethodCall resolvedServiceMethods}+  private Client c_;+  private RPCInterface iface_;+};+|]+  where+    className = (formatClassNameT serviceName) `mappend` "Client"+    genMethodCall Function {..} =+        let args = T.intercalate ", " $ map genArgs' methodArgs+            vals = T.intercalate ", " $ pack methodArgs genVal in+        case methodRetType of+          TVoid -> [lt|+  public void #{methodName}(#{args}) {+    iface_.#{methodName}(#{vals});+  }+|]+          _ -> [lt|+  public #{genType methodRetType} #{methodName}(#{args}) {+    return iface_.#{methodName}(#{vals});+  }+|]+    genMethodCall _ = ""++genClient _ _ _ = return ()++genSignature :: Method -> LT.Text+genSignature Function {..} = +    [lt|    #{genType methodRetType} #{methodName}(#{args});+|]+    where+      args = (T.intercalate ", " $ map genArgs' methodArgs)+genSignature  _ = ""++genArgs :: Maybe Field -> T.Text+genArgs (Just field) = genArgs' field+genArgs Nothing = ""++genArgs' :: Field -> T.Text+genArgs' Field {..} = [st|#{genType fldType} #{fldName}|]++pack :: [Field] -> (Maybe Field -> T.Text) -> [T.Text]+pack fields converter=+  let ixs = map (\f -> fldId f) fields+      dic = zip ixs [0..]+      m = maximum (-1 :ixs)+      sortedIxs = [ lookup ix dic | ix <- [0..m]] :: [Maybe Int] in+  map (\sIx -> case sIx of +                 Nothing -> converter Nothing +                 Just i  -> converter $ Just (fields!!i) ) sortedIxs++genVal :: Maybe Field -> T.Text+genVal Nothing = "null"+genVal (Just field) = fldName field++formatClassNameT :: T.Text -> T.Text+formatClassNameT = T.pack . formatClassName . T.unpack++formatClassName :: String -> String+formatClassName = concatMap (\(c:cs) -> toUpper c:cs) . words . map (\c -> if c=='_' then ' ' else c)++genServer :: Decl -> LT.Text+genServer _ = ""++genLiteral :: Literal -> LT.Text+genLiteral (LInt i) = [lt|#{show i}|]+genLiteral (LFloat d) = [lt|#{show d}|]+genLiteral (LBool b) = [lt|#{show b}|]+genLiteral LNull = [lt|null|]+genLiteral (LString s) = [lt|#{show s}|]++associateBracket :: [LT.Text] -> LT.Text+associateBracket msgParam = +  if null msgParam then "" else [lt|<#{LT.intercalate ", " msgParam}>|]+++genType :: Type -> LT.Text+genType (TInt _ bits) = case bits of+                            8 -> [lt|byte|]+                            16 -> [lt|short|]+                            32 -> [lt|int|]+                            64 -> [lt|long|]+                            _ -> [lt|int|]+genType (TFloat False) =+  [lt|float|]+genType (TFloat True) =+  [lt|double|]+genType TBool =+  [lt|boolean|]+genType TRaw =+  [lt|String|]+genType TString =+  [lt|String|]+genType (TList typ) =+  [lt|ArrayList<#{genWrapperType typ} >|]+genType (TMap typ1 typ2) =+  [lt|HashMap<#{genType typ1}, #{genType typ2} >|]+genType (TUserDef className params) =+  [lt|#{formatClassNameT className} #{associateBracket $ map genType params}|]+genType (TTuple ts) =+  -- TODO: FIX+  foldr1 (\t1 t2 -> [lt|Tuple<#{t1}, #{t2} >|]) $ map genWrapperType ts+genType TObject =+  [lt|org.msgpack.type.Value|]+genType TVoid =+  [lt|void|]++genTypeWithContext :: Spec -> Type -> LT.Text+genTypeWithContext spec t = case t of +                              (TUserDef className params) -> +                                  case lookup className $ map genAlias $ filter isMPType spec of+                                    Just x -> genType x+                                    Nothing -> ""+                              otherwise -> genType t++isMPType :: Decl -> Bool+isMPType MPType {..} = True+isMPType _ = False++genAlias :: Decl -> (T.Text, Type)+genAlias MPType {..} = (tyName, tyType)+genAlias _ = ("", TBool)++genTypeWithTypedef :: T.Text -> Decl -> Maybe Type+genTypeWithTypedef className MPType {..} =+  if className == tyName then Just tyType else Nothing+genTypeWithTypedef className _ = Nothing++genWrapperType :: Type -> LT.Text+genWrapperType (TInt _ bits) = case bits of+                                 8 -> [lt|Byte|]+                                 16 -> [lt|Short|]+                                 32 -> [lt|Integer|]+                                 64 -> [lt|Long|]+                                 _ -> [lt|Integer|]+genWrapperType (TFloat False) =+  [lt|Float|]+genWrapperType (TFloat True) =+  [lt|Double|]+genWrapperType TBool =+  [lt|Boolean|]+genWrapperType TRaw =+  [lt|String|]+genWrapperType TString =+  [lt|String|]+genWrapperType (TList typ) =+  [lt|ArrayList<#{genWrapperType typ} >|]+genWrapperType (TMap typ1 typ2) =+  [lt|HashMap<#{genWrapperType typ1}, #{genWrapperType typ2} >|]+genWrapperType (TUserDef className params) =+  [lt|#{formatClassNameT className} #{associateBracket $ map genWrapperType params}|]+genWrapperType (TTuple ts) =+  -- TODO: FIX+  foldr1 (\t1 t2 -> [lt|Tuple<#{t1}, #{t2} >|]) $ map genWrapperType ts+genWrapperType TObject =+  [lt|org.msgpack.type.Value|]+genWrapperType TVoid =+  [lt|void|]++templ :: FilePath -> LT.Text -> LT.Text+templ filepath content = [lt|+// This file is auto-generated from #{filepath}+// *** DO NOT EDIT ***++#{content}++|]
+ Language/MessagePack/IDL/CodeGen/Perl.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}++module Language.MessagePack.IDL.CodeGen.Perl (+  Config(..),+  generate,+  ) where++import Data.Char+import Data.List+import qualified Data.Text 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++-- types+  mapM_ writeType spec++-- clients+  LT.writeFile (name ++ "_client.pm") [lt|+package #{name}_client;+use strict;+use warnings;+use AnyEvent::MPRPC::Client;+#{LT.concat $ map genClient spec}+|]++writeType :: Decl -> IO ()+writeType MPMessage {..} =+  let fields = sortBy (\x y -> fldId x `compare` fldId y) msgFields+      fieldNames = map fldName fields :: [T.Text]+      packageName = msgName :: T.Text+  in LT.writeFile (T.unpack packageName ++ ".pm") [lt|package #{LT.pack $ T.unpack packageName};+sub new {+  return bless { #{LT.concat $ map f fieldNames} };+}++1;+|]+  where+    f :: T.Text -> LT.Text+    f name = LT.append (LT.pack $ T.unpack name) $ LT.pack " => \"\","++writeType MPException {..} =+  let fields = sortBy (\x y -> fldId x `compare` fldId y) excFields+      fieldNames = map fldName fields :: [T.Text]+      packageName = excName :: T.Text+  in LT.writeFile (T.unpack packageName ++ ".pm") [lt|package #{LT.pack $ T.unpack packageName};+sub new {+  return bless { #{LT.concat $ map f fieldNames} };+}++1;+|]+  where+    f :: T.Text -> LT.Text+    f name = LT.append (LT.pack $ T.unpack name) $ LT.pack " => \"\",\n"++writeType _ = return ()++genClient :: Decl -> LT.Text+genClient MPService {..} = [lt|+sub new {+  my ($self, $host, $port) = @_;+  my $client = AnyEvent::MPRPC::Client->new(+    host => $host,+    port => $port+    );+  bless { client => $client }, $self;+};++sub bar {+  my ($self, $lang, $xs) = @_;+  $self->{'client'}->call(bar => [$xs, $lang])->recv;+};++1;+|]+  where+  genMethodCall Function {..} =+    let args = LT.intercalate ", " $ map arg methodArgs in+    let vals = LT.concat $ map val methodArgs in+    [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 ***++#{content}++|]
+ Language/MessagePack/IDL/CodeGen/Php.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}++module Language.MessagePack.IDL.CodeGen.Php (+  Config(..),+  generate,+  ) where++import Data.Char+import Data.List+import qualified Data.Text 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 Data.Monoid++import Language.MessagePack.IDL.Syntax++data Config+  = Config+    { configFilePath :: FilePath+    }+  deriving (Show, Eq)++generate:: Config -> Spec -> IO ()+generate Config {..} spec = do+  let name = takeBaseName configFilePath+      once = map toUpper name+      +  LT.writeFile (name ++ "_types.php") $ templ configFilePath once "TYPES" [lt|+include_once 'Net/MessagePackRPC.php';++#{LT.concat $ map genTypeDecl spec}++class ObjectDecoder {+  public static $USER_DEFINED_CLASSES = array(+    #{LT.concat $ map genClassName spec}+  );+  public static function decodeToObject($ret_array, $type_array) {+    if ($type_array == "") {+      // do nothing+      $ret = $ret_array;+    } else if (in_array($type_array, self::$USER_DEFINED_CLASSES)) {+      // array -> object+      $ret = new $type_array();+      $ret_keys = array_keys((array)$ret);+      for ($i = 0; $i < count($ret_keys); $i++) {+        $ret->{$ret_keys[$i]} = $ret_array[$i];+      }+    } else {+      // dissolve array+      if (is_array($type_array)) {+        if (count($type_array) == 1) {+          // if array+          foreach ($type_array as $key => $type) {+            foreach ($ret_array as $ret_key => $ret_value) {+              $ret[$ret_key] = $this->decodeToObject($ret_value, $type);+            }+          }+        } else {+          // if tuple+          $ret = array();+          $i = 0;+          foreach ($type_array as $type) {+            $ret[$i] = $this->decodeToObject($ret_array[$i], $type);+            $i++;+          }+        }+      } else {+        // type error+        return $ret_array;+      }+    }+    return $ret;+  }+}+ +|]++  LT.writeFile (name ++ "_client.php") [lt|+<?php+include_once(dirname(__FILE__)."/#{name}_types.php");++#{LT.concat $ map genClient spec}+?>+|]++genClassName :: Decl -> LT.Text+genClassName MPMessage {..} =+  [lt|  "#{msgName}",+  |]  +genClassName _ = ""++genTypeDecl :: Decl -> LT.Text+genTypeDecl MPMessage {..} =+  genMsg msgName msgFields False++genTypeDecl MPException {..} =+  genMsg excName excFields True++genTypeDecl _ = ""++genMsg name flds isExc =+  let fields = map f flds+      fs = map (maybe undefined fldName) $ sortField flds+  in [lt|+class #{name}#{e} {++#{LT.concat fields}+}+|]+  where+    e = if isExc then [lt| extends Exception|] else ""++    f Field {..} = [lt| public $#{fldName};+|]++sortField flds =+  flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix ->+  find ((==ix). fldId) flds++genClient :: Decl -> LT.Text+genClient MPService {..} = [lt|+class #{serviceName} {+  public function __construct($host, $port) {+    $this->client = new MessagePackRPC_Client($host, $port);+  }+#{LT.concat $ map genMethodCall serviceMethods}+  private $client;+}+|]+  where+  genMethodCall Function {..} =+    let args = LT.intercalate ", " $ map arg methodArgs in+    let sortedArgs = LT.intercalate ", " $ map (maybe undefined arg) $ sortField methodArgs in+    case methodRetType of+      TVoid -> [lt|+  public function #{methodName}(#{args}) {+    $this->client->call("#{methodName}", array(#{sortedArgs}));+  }+|]+      _ -> [lt|+  public function #{methodName}(#{args}) {+    $ret = $this->client->call("#{methodName}", array(#{sortedArgs}));+    $type_array = #{genTypeArray methodRetType};+    return ObjectDecoder::decodeToObject($ret, $type_array);+  }+|]+    where+      arg Field {..} = [lt|$#{fldName}|]++  genMethodCall _ = ""+  +genClient _ = ""++genTypeArray :: Type -> LT.Text+genTypeArray (TList typ) =+  [lt|array(#{genTypeArray typ})|]+genTypeArray (TMap typ1 typ2) =+  [lt|array(#{genTypeArray typ1} => #{genTypeArray typ2})|]+genTypeArray (TUserDef className params) =+  [lt|"#{className}"|]+genTypeArray (TTuple ts) =+  foldr1 (\t1 t2 -> [lt|array(#{t1}, #{t2})|]) $ map genTypeArray ts+genTypeArray _ = [lt|""|]++genType :: Type -> LT.Text+genType (TUserDef className params) =+  [lt|#{className}|]+genType _ = ""++templ :: FilePath -> String -> String -> LT.Text -> LT.Text+templ filepath once name content = [lt|+// This file is auto-generated from #{filepath}+// *** DO NOT EDIT ***+<?php+#{content}+?>+|]+    +snoc xs x = xs ++ [x]
+ Language/MessagePack/IDL/CodeGen/Py.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}++module Language.MessagePack.IDL.CodeGen.Py (+  Config(..),+  generate,+  ) where++import Data.List+import Data.Monoid+import qualified Data.Text 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 }+  deriving (Show, Eq)++generate:: Config -> Spec -> IO ()+generate Config {..} spec = do+  let name = takeBaseName configFilePath++      typeHeader = [lt|import msgpack|]+      serverHeader = [lt|import msgpackrpc|]+      clientHeader = [lt|import msgpackrpc|]+  +  LT.writeFile (name ++ "_types.py") $ templ "TYPES" [lt|+import sys+#{typeHeader}++#{LT.concat $ map (genTypeDecl name) spec }+|]++  LT.writeFile (name ++ "_server.py") $ templ "SERVER" [lt|+import #{name}_types+#{serverHeader}+|]++  LT.writeFile (name ++ "_client.py") [lt|+import #{name}_types+#{clientHeader}+#{LT.concat $ map (genClient) spec}+|]++genTypeDecl :: String -> Decl -> LT.Text++genTypeDecl _ MPMessage {..} =+  genMsg msgName msgFields False++genTypeDecl _ MPException {..} =+  genMsg excName excFields True++genTypeDecl _ _ = ""++genMsg name flds isExc =+  let fields = map f flds+      types = map typ flds+      fs = map (maybe undefined fldName) $ sortField flds+  in [lt|+class #{name}#{e}:++  def __init__(self#{LT.concat $ map g fs}):+#{LT.concat fields}+  def to_array(self):+    variables = []+#{LT.concat types}+    return variables+|]++  where+    e = if isExc then [lt|(Exception)|] else ""+    f Field {..} = [lt|    self.#{fldName} = #{fldName}+|]+    typ Field {..} = let selfName = "self." `mappend` fldName+                     in [lt|    variables.append(#{genType fldType selfName})+|]+    g str = [lt|, #{str}|]++sortField flds =+  flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix ->+  find ((==ix). fldId) flds++genClient :: Decl -> LT.Text+genClient MPService {..} = [lt|+class #{serviceName}:+  def __init__ (self, host, port):+    address = msgpackrpc.Address(host, port)+    self.client = msgpackrpc.Client(address)+#{LT.concat $ map genMethodCall serviceMethods}+|]+  where+  genMethodCall Function {..} =+    let arg_list = map (maybe undefined fldName) $ sortField methodArgs+        args = LT.concat $ map arg arg_list+        to_arrays = LT.concat $ map to_array methodArgs in+    case methodRetType of+      TVoid -> [lt|+  def #{methodName} (self#{args}):+#{to_arrays}+    self.client.call('#{methodName}'#{args})+|]+      _ -> [lt|+  def #{methodName} (self#{args}):+#{to_arrays}+    return self.client.call('#{methodName}'#{args})+|]+    where+      arg str = [lt|, #{str}|]+      to_array Field {..} = [lt|    #{fldName} = #{genType fldType fldName}+|]++  genMethodCall _ = ""++genClient _ = ""++genType :: Type -> T.Text -> LT.Text+genType (TInt sign bits) name = [lt|#{name}|]+genType (TFloat False) name = [lt|#{name}|]+genType (TFloat True) name = [lt|#{name}|]+genType TBool name = [lt|#{name}|]+genType TRaw name = [lt|#{name}|]+genType TString name = [lt|#{name}|]+genType (TList typ) name =+  [lt|[#{genType typ "elem"} for elem in #{name}]|]+genType (TMap typ1 typ2) name =+  [lt|{#{genType typ1 "k"} : #{genType typ2 "v"} for k,v in #{name}.items()}|]+genType (TUserDef className params) name = [lt|#{name}.to_array()|]+genType (TTuple ts) name = [lt|#{name}.to_array()|]+  -- TODO: FIX+  -- foldr1 (\t1 t2 -> [lt|std::pair<#{t1}, #{t2} >|]) $ map genType ts+genType TObject name = [lt|#{name}.to_array()|]+genType TVoid name = ""+++templ :: FilePath -> LT.Text -> LT.Text+templ filepath content = [lt|+#/usr/bin/python+# -*- coding:utf-8 -*-++# This file is auto-generated from #{filepath}+# *** DO NOT EDIT ***++#{content}+|]
+ Language/MessagePack/IDL/CodeGen/Ruby.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-}++module Language.MessagePack.IDL.CodeGen.Ruby (+  Config(..),+  generate,+  ) where++import Data.Char+import Data.List+import Data.Monoid+import qualified Data.Text 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+    , configModule :: String+    }+  deriving (Show, Eq)++generate:: Config -> Spec -> IO ()+generate Config {..} spec = do+  let name = takeBaseName configFilePath+      once = map toUpper name+      mods = LT.splitOn "::" $ LT.pack configModule+  LT.writeFile (name ++ "_types.rb") $ templ configFilePath [lt|+require 'msgpack/rpc'++#{genModule mods $ LT.concat $ map (genTypeDecl name) spec }|]+  +  LT.writeFile (name ++ "_client.rb") $ templ configFilePath [lt|+require 'msgpack/rpc'+require './#{name}_types'++#{genModule (snoc mods "Client") $ LT.concat $ map genClient spec}|]++genTypeDecl :: String -> Decl -> LT.Text+genTypeDecl _ MPMessage {..} =+  genMsg msgName msgFields False++genTypeDecl _ MPException {..} =+  genMsg excName excFields True+  +genTypeDecl _ _ = ""++genMsg name flds isExc = [lt|+class #{capitalizeT name}#{deriveError}+  def to_msgpack(out = '')+    [#{afs}].to_msgpack(out)+  end++  def from_unpacked(unpacked)+    #{afs} = unpacked+  end++#{indent 2 $ LT.concat writers}++#{indent 2 $ genAccessors sorted_flds}+end+|]+  where+    sorted_flds = sortField flds+    fs = map (maybe undefined fldName) sorted_flds+    writers = map (maybe undefined genAttrWriter) sorted_flds+    afs = T.intercalate ", " $ map (mappend "@") fs+    deriveError = if isExc then [lt| < StandardError|] else ""++capitalizeT :: T.Text -> T.Text+capitalizeT a = T.cons (toUpper $ T.head a) (T.tail a)++sortField flds =+  flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> find ((==ix). fldId) flds++indent :: Int -> LT.Text -> LT.Text+indent ind lines = indentedConcat ind $ LT.lines lines++indentedConcat :: Int -> [LT.Text] -> LT.Text+indentedConcat ind lines =+  LT.dropAround (== '\n') $ LT.unlines $ map (indentLine ind) lines++indentLine :: Int -> LT.Text -> LT.Text+indentLine ind "" = ""+indentLine ind line = mappend (LT.pack $ replicate ind ' ') line++extractJust :: [Maybe a] -> [a]+extractJust [] = []+extractJust (Nothing:xs) = extractJust xs+extractJust (Just v:xs)  = v : extractJust xs++data AccessorType = Read | ReadWrite deriving Eq++getAccessorType :: Type -> AccessorType+getAccessorType TBool = Read+getAccessorType (TMap _ _) = Read+getAccessorType (TUserDef _ _) = Read+getAccessorType _ = ReadWrite++genAccessors :: [Maybe Field] -> LT.Text+genAccessors [] = ""+genAccessors fs = [lt|+#{genAccessors' Read "attr_reader" fs}#{genAccessors' ReadWrite "attr_accessor" fs}|]++genAccessors' :: AccessorType -> String -> [Maybe Field] -> LT.Text+genAccessors' at an flds = gen $ map (maybe undefined fldName) $ filter fldTypeEq flds+  where+    gen [] = ""+    gen fs = [lt|+#{an} #{T.intercalate ", " $ map (mappend ":") fs}|]++    fldTypeEq (Just Field {..}) = at == getAccessorType fldType+    fldTypeEq Nothing           = False+++-- TODO: Check when val is not null with TNullable+-- TODO: Write single precision value on TFloat False+genAttrWriter :: Field -> LT.Text+genAttrWriter Field {..} = genAttrWriter' fldType fldName++genAttrWriter' :: Type -> T.Text -> LT.Text++genAttrWriter' TBool n = [lt|+def #{n}=(val)+  @#{n} = val.to_b+end+|]++genAttrWriter' (TMap kt vt) n = [lt|+def #{n}=(val)+  @#{n} = {}+  val.each do |k, v|+#{indent 4 $ convert "k" "newk" kt}+#{indent 4 $ convert "v" "newv" vt}+  end+end+|]+  where+    convert from to (TUserDef t p) =+        genConvertingType from to (TUserDef t p)+    convert from to _ = [lt|#{to} = #{from}|]++genAttrWriter' (TUserDef name types) n = [lt|+def #{n}=(val)+#{indent 2 $ convert "val" atn (TUserDef name types)}+end+|]+  where+    atn = [lt|@#{n}|]+    convert from to (TUserDef t p) =+        genConvertingType from to (TUserDef t p)++genAttrWriter' _ _ = ""++genClient :: Decl -> LT.Text+genClient MPService {..} = [lt|+class #{capitalizeT serviceName}+  def initialize(host, port)+    @cli = MessagePack::RPC::Client.new(host, port)+  end#{LT.concat $ map genMethodCall serviceMethods}+end+|]+  where+    genMethodCall Function {..} = [lt|+  def #{methodName}(#{defArgs})+#{indent 4 $ genConvertingType' callStr "v" methodRetType}+  end|]+      where+        defArgs = T.intercalate ", " $ map fldName methodArgs+        callStr = [lt|@cli.call(#{callArgs})|]+        callArgs = mappend ":" $ T.intercalate ", " $ methodName : sortedArgNames+        sortedArgNames = map (maybe undefined fldName) $ sortField methodArgs++genClient _ = ""++genConvertingType :: LT.Text -> LT.Text -> Type -> LT.Text+genConvertingType unpacked v (TUserDef t _) = [lt|+#{v} = #{capitalizeT t}.new+#{v}.from_unpacked(#{unpacked})|]+genConvertingType _ _ _ = ""++genConvertingType' :: LT.Text -> LT.Text -> Type -> LT.Text+genConvertingType' unpacked v (TUserDef t p) = [lt|+#{genConvertingType unpacked v (TUserDef t p)}+return v|]+genConvertingType' unpacked _ _ = [lt|#{unpacked}|]++templ :: FilePath -> LT.Text -> LT.Text+templ filepath content = [lt|# This file is auto-generated from #{filepath}+# *** DO NOT EDIT ***+#{content}+|]++genModule :: [LT.Text] -> LT.Text -> LT.Text+genModule modules content = f modules+  where+    f [] = [lt|#{content}|]+    f (n:ns) = [lt|module #{n}+#{f ns}+end|]++snoc xs x = xs ++ [x]
+ Language/MessagePack/IDL/Parser.hs view
@@ -0,0 +1,14 @@+{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}++module Language.MessagePack.IDL.Parser (+  idl,+  ) where++import Data.Maybe+import qualified Data.Text as T+import Text.Peggy+import Text.Peggy.CodeGen.TH++import Language.MessagePack.IDL.Syntax++genDecs $(peggyFile "mpidl.peggy")
+ Language/MessagePack/IDL/Syntax.hs view
@@ -0,0 +1,75 @@+module Language.MessagePack.IDL.Syntax where++import qualified Data.Text as T++type Spec = [Decl]++data Decl+  = MPMessage+    { msgName :: T.Text+    , msgParam :: [T.Text]+    , msgFields :: [Field]+    }+  | MPException+    { excName :: T.Text+    , excParam :: [T.Text]+    , excSuper :: Maybe T.Text+    , excFields :: [Field]+    }+  | MPType+    { tyName :: T.Text+    , tyType :: Type+    }+  | MPEnum+    { enumName :: T.Text+    , enumMem :: [(Int, T.Text)]+    }+  | MPService+    { serviceName :: T.Text+    , serviceVersion :: Maybe Int+    , serviceMethods :: [Method]+    }+  deriving (Eq, Show)++data Field+  = Field+    { fldId :: Int+    , fldType :: Type+    , fldName :: T.Text+    , fldDefault :: Maybe Literal+    }+  deriving (Eq, Show)++data Method+  = Function+    { methodInherit :: Bool+    , methodName :: T.Text+    , methodRetType :: Type+    , methodArgs :: [Field]+    }+  | InheritName T.Text+  | InheritAll+  deriving (Eq, Show)++data Type+  = TInt Bool Int -- signed? bits+  | TFloat Bool   -- double prec?+  | TBool+  | TRaw+  | TString+  | TNullable Type+  | TList Type+  | TMap Type Type+  | TTuple [Type]+  | TUserDef T.Text [Type]+  | TObject+  | TVoid+  deriving (Eq, Show)++data Literal+  = LInt Int+  | LFloat Double+  | LBool Bool+  | LNull+  | LString T.Text+  deriving (Eq, Show)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exec/Main.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}++import Control.Exception+import Data.Version+import System.Console.CmdArgs+import System.Directory+import Text.Peggy++import Language.MessagePack.IDL+import qualified Language.MessagePack.IDL.CodeGen.Haskell as Haskell+import qualified Language.MessagePack.IDL.CodeGen.Cpp as Cpp+import qualified Language.MessagePack.IDL.CodeGen.Ruby as Ruby+import qualified Language.MessagePack.IDL.CodeGen.Java as Java+import qualified Language.MessagePack.IDL.CodeGen.Php as Php+import qualified Language.MessagePack.IDL.CodeGen.Py as Py+import qualified Language.MessagePack.IDL.CodeGen.Perl as Perl++import Paths_msgpack_idl++data MPIDL+  = Haskell+  | Cpp+    { output_dir :: FilePath+    , namespace :: String+    , pficommon :: Bool+    , filepath :: FilePath }+  | Ruby+    { output_dir :: FilePath+    , modules :: String+    , filepath :: FilePath }+  | Java+    { output_dir :: FilePath+    , package :: String+    , filepath :: FilePath+    }+  | Php+    { output_dir :: FilePath+    , filepath :: FilePath+    }+  | Py+    { output_dir :: FilePath+     , filepath :: FilePath+    }+  | Perl+    { output_dir :: FilePath+    , namespace :: String+    , filepath :: FilePath }+  deriving (Show, Eq, Data, Typeable)++main :: IO ()+main = do+  conf <- cmdArgs $+    modes [ Haskell+          , Cpp { output_dir = def+                , namespace = "msgpack"+                , pficommon = False+                , filepath = def &= argPos 0+                }+          , Ruby { output_dir = def+                 , modules = "MessagePack"+                 , filepath = def &= argPos 0+                 }+          , Java { output_dir = def+                 , package = "msgpack"+                 , filepath = def &= argPos 0+                 }+          , Php { output_dir = def+                , filepath = def &= argPos 0+                }+          , Py  { output_dir = def+                }+          , Perl { output_dir = def+                , namespace = "msgpack"+                , filepath = def &= argPos 0+                }+          ]+    &= help "MessagePack RPC IDL Compiler"+    &= summary ("mpidl " ++ showVersion version)++  compile conf++compile :: MPIDL -> IO ()+compile conf = do+  espec <- parseFile idl (filepath conf)+  case espec of+    Left err -> do+      print err+    Right spec -> do+      print spec+      case conf of+        Cpp {..} -> do+          withDirectory output_dir $ do+            Cpp.generate (Cpp.Config filepath namespace pficommon) spec+        +        Java {..} -> do+          withDirectory (output_dir ++ "/" ++ package) $ do+            Java.generate (Java.Config filepath package) spec++        Php {..} -> do+          withDirectory (output_dir) $ do+            Php.generate (Php.Config filepath) spec+ +        Ruby {..} -> do+          withDirectory (output_dir) $ do+            Ruby.generate (Ruby.Config filepath modules) spec++        Perl {..} -> do+          withDirectory output_dir $ do+            Perl.generate (Perl.Config filepath namespace) spec++withDirectory :: FilePath -> IO a -> IO a+withDirectory dir m = do+  createDirectoryIfMissing True dir+  bracket+    getCurrentDirectory+    setCurrentDirectory+    (\_ -> setCurrentDirectory dir >> m)
+ mpidl.peggy view
@@ -0,0 +1,84 @@+idl :: Spec = decl* !.++decl :: Decl+  = "message" identifier typeParam "{" field* "}"+    { MPMessage $1 $2 $3 }+  / "exception" identifier typeParam ("<" identifier)? "{" field* "}"+    { MPException $1 $2 $3 $4 }+  / "type" identifier "=" ftype+    { MPType $1 $2 }+  / "enum" identifier "{" (integer ":" identifier)* "}"+    { MPEnum $1 $2 }+  / "service" identifier (":" integer)? "{" method* "}"+    { MPService $1 $2 $3 }++typeParam :: [T.Text]+  = "<" (identifier, ",") ">"+  / "" { [] }++method :: Method+  = "inherit" identifier { InheritName $1 }+  / "inherit" "*" { InheritAll }+  / "inherit"? ftype identifier "(" (field , ",") ")"+    { Function (isJust $1) $3 $2 $4 }++field :: Field+  = integer ":" ftype identifier ("=" literal)?+    { Field $1 $2 $3 $4 }++ftype :: Type+  = ftypeNN "?" { TNullable $1 }+  / ftypeNN++ftypeNN :: Type+  = "byte"   { TInt True  8  }+  / "short"  { TInt True  16 }+  / "int"    { TInt True  32 }+  / "long"   { TInt True  64 }+  / "ubyte"  { TInt False 8  }+  / "ushort" { TInt False 16 }+  / "uint"   { TInt False 32 }+  / "ulong"  { TInt False 64 }+  / "float"  { TFloat False }+  / "double" { TFloat True }+  / "bool"   { TBool }+  / "raw"    { TRaw }+  / "string" { TString }+  / "void"   { TVoid }+  / "object" { TObject }++  / "list" "<" ftype ">" { TList $1 }+  / "map" "<" ftype "," ftype ">" { TMap $1 $2 }+  / "tuple" "<" (ftype , ",") ">" { TTuple $1 }++  / identifier ("<" (ftype , ",") ">")?+    { TUserDef $1 (fromMaybe [] $2) }++literal ::: Literal+  = integer { LInt $1 }+  / "true"  { LBool True }+  / "false" { LBool False }+  / "null"  { LNull }+  / '\"' charLit* '\"' { LString $ T.pack $1 }++charLit :: Char+  = '\\' escChar+  / ![\'\"] .++escChar :: Char+  = 'n' { '\n' }+  / 'r' { '\r' }+  / 't' { '\t' }+  / '\\' { '\\' }+  / '\"' { '\"' }+  / '\'' { '\'' }++integer ::: Int+  = [0-9]+ { read $1 }++identifier ::: T.Text+  = [a-zA-Z_][a-zA-Z0-9_]* { T.pack ($1 : $2) }++skip :: () = [ \r\n\t] { () } / comment+comment :: () = '#' _:(!'\n' . { () })* '\n' { () }+delimiter :: () = [()[\]{}<>;:,./?] { () }
+ msgpack-idl.cabal view
@@ -0,0 +1,58 @@+Name:                msgpack-idl+Version:             0.1.0+Synopsis:            An IDL Compiler for MessagePack+Description:         An IDL Compiler for MessagePack <http://msgpack.org/>+Homepage:            http://msgpack.org/+License:             BSD3+License-file:        LICENSE+Author:              Hideyuki Tanaka+Maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>+Copyright:           Copyright (c) 2011, Hideyuki Tanaka+Category:            Language+Stability:           Experimental+Cabal-version:       >=1.8+Build-type:          Simple++Extra-source-files:  mpidl.peggy++Source-repository head+  Type:                git+  Location:            git://github.com/msgpack/msgpack-haskell.git++Library+  Build-depends:       base             == 4.*+                     , bytestring       == 0.9.*+                     , text             == 0.11.*+                     , shakespeare-text == 0.10.*+                     , blaze-builder    == 0.3.*+                     , template-haskell >= 2.5 && < 2.8+                     , containers       == 0.4.*+                     , filepath         >= 1.2 && < 1.4+                     , msgpack          == 0.7.*+                     , peggy            == 0.3.*++  Ghc-options:         -Wall+  +  Exposed-modules:     Language.MessagePack.IDL+                       Language.MessagePack.IDL.Check+                       Language.MessagePack.IDL.CodeGen.Cpp+                       Language.MessagePack.IDL.CodeGen.Haskell+                       Language.MessagePack.IDL.CodeGen.Java+                       Language.MessagePack.IDL.CodeGen.Perl+                       Language.MessagePack.IDL.CodeGen.Php+                       Language.MessagePack.IDL.CodeGen.Py+                       Language.MessagePack.IDL.CodeGen.Ruby+                       Language.MessagePack.IDL.Parser+                       Language.MessagePack.IDL.Syntax+  +  Other-modules:       ++Executable mpidl+  Hs-source-dirs:      exec+  Main-is:             Main.hs++  Build-depends:       base      == 4.*+                     , directory == 1.1.*+                     , cmdargs   == 0.9.*+                     , peggy     == 0.3.*+                     , msgpack-idl