From 4c39b127487d8d457e6707e8437e8e0f39991dea Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Wed, 20 Jun 2012 16:57:23 +0900 Subject: [PATCH 1/8] fix deprecate use of hspecX --- msgpack-idl/test/test.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/msgpack-idl/test/test.hs b/msgpack-idl/test/test.hs index 6372586..e17b082 100644 --- a/msgpack-idl/test/test.hs +++ b/msgpack-idl/test/test.hs @@ -1,7 +1,7 @@ import Test.Hspec.Monadic main :: IO () -main = hspecX $ do +main = hspec $ do describe "parser" $ do it "can parse xxx..." $ do pending From 50a48598b11c0808fc33b49068eb5a212f408c20 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Wed, 20 Jun 2012 17:07:50 +0900 Subject: [PATCH 2/8] Type-Checker Monad --- msgpack-idl/Language/MessagePack/IDL/Check.hs | 50 ++++++++++++++++++- msgpack-idl/msgpack-idl.cabal | 2 + 2 files changed, 50 insertions(+), 2 deletions(-) diff --git a/msgpack-idl/Language/MessagePack/IDL/Check.hs b/msgpack-idl/Language/MessagePack/IDL/Check.hs index 3207365..fe7153f 100644 --- a/msgpack-idl/Language/MessagePack/IDL/Check.hs +++ b/msgpack-idl/Language/MessagePack/IDL/Check.hs @@ -1,9 +1,55 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + module Language.MessagePack.IDL.Check ( check, ) where +import Control.Monad +import Control.Monad.State +import Control.Monad.Error +import Data.Data +import Data.Lens.Lazy +import Data.Lens.Template +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Text.Shakespeare.Text + import Language.MessagePack.IDL.Syntax --- TODO: Implement it! +data TcEnv + = TcEnv + { _envTypes :: M.Map T.Text Type + } +makeLens ''TcEnv + +emptyEnv :: TcEnv +emptyEnv = TcEnv + { _envTypes = M.empty + } + +data TcError = TcError T.Text + deriving (Show, Data, Typeable) + +instance Error TcError where + strMsg = TcError . T.pack + +type TcM = StateT TcEnv (Either TcError) + check :: Spec -> Bool -check _ = True +check decls = + let types = execStateT (mapM_ genTypes decls) emptyEnv + in False + +genTypes :: Decl -> TcM () +genTypes decl = case decl of + MPMessage {..} -> + focus envTypes $ do + mb <- access $ mapLens msgName + when (isJust mb) $ + throwError $ TcError [st|message "#{msgName}" is already defined|] + + _ -> do + return () diff --git a/msgpack-idl/msgpack-idl.cabal b/msgpack-idl/msgpack-idl.cabal index 6f24209..4b0781c 100644 --- a/msgpack-idl/msgpack-idl.cabal +++ b/msgpack-idl/msgpack-idl.cabal @@ -31,6 +31,8 @@ library , directory , msgpack == 0.7.* , peggy == 0.3.* + , data-lens >= 2.10 + , data-lens-template >= 2.1 ghc-options: -Wall From 155740ea32631078559d25855894e93b28a3f7ff Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Wed, 20 Jun 2012 18:17:47 +0900 Subject: [PATCH 3/8] test added --- msgpack-idl/Language/MessagePack/IDL/Check.hs | 9 ++++-- msgpack-idl/msgpack-idl.cabal | 12 ++++++-- msgpack-idl/test/test.hs | 30 +++++++++++++++++-- 3 files changed, 42 insertions(+), 9 deletions(-) diff --git a/msgpack-idl/Language/MessagePack/IDL/Check.hs b/msgpack-idl/Language/MessagePack/IDL/Check.hs index fe7153f..54c5191 100644 --- a/msgpack-idl/Language/MessagePack/IDL/Check.hs +++ b/msgpack-idl/Language/MessagePack/IDL/Check.hs @@ -38,10 +38,11 @@ instance Error TcError where type TcM = StateT TcEnv (Either TcError) -check :: Spec -> Bool +check :: Spec -> Either TcError () check decls = - let types = execStateT (mapM_ genTypes decls) emptyEnv - in False + case execStateT (mapM_ genTypes decls) emptyEnv of + Left err -> Left err + Right ts -> Right () genTypes :: Decl -> TcM () genTypes decl = case decl of @@ -50,6 +51,8 @@ genTypes decl = case decl of mb <- access $ mapLens msgName when (isJust mb) $ throwError $ TcError [st|message "#{msgName}" is already defined|] + mapLens msgName ~= Just undefined + return () _ -> do return () diff --git a/msgpack-idl/msgpack-idl.cabal b/msgpack-idl/msgpack-idl.cabal index 4b0781c..b944951 100644 --- a/msgpack-idl/msgpack-idl.cabal +++ b/msgpack-idl/msgpack-idl.cabal @@ -21,6 +21,7 @@ source-repository head library build-depends: base == 4.* + , mtl >= 2.1 , bytestring == 0.9.* , text == 0.11.* , shakespeare-text == 1.0.* @@ -54,9 +55,9 @@ executable mpidl main-is: main.hs build-depends: base == 4.* - , directory >= 1.0 && < 1.2 , cmdargs == 0.9.* - , peggy == 0.3.* + , directory + , peggy , msgpack-idl test-suite mpidl-test @@ -65,5 +66,10 @@ test-suite mpidl-test main-is: test.hs build-depends: base == 4.* - , hspec >= 1.1 + , hspec >= 1.2 + , HUnit >= 1.2 + , text + , shakespeare-text + , peggy + , listlike-instances , msgpack-idl diff --git a/msgpack-idl/test/test.hs b/msgpack-idl/test/test.hs index e17b082..4c58d07 100644 --- a/msgpack-idl/test/test.hs +++ b/msgpack-idl/test/test.hs @@ -1,4 +1,14 @@ -import Test.Hspec.Monadic +{-# LANGUAGE QuasiQuotes #-} +import Data.ListLike.Text () +import qualified Data.Text as T +import Test.Hspec.Monadic hiding (Spec) +import Test.Hspec.HUnit +import Test.HUnit +import Text.Peggy +import Text.Shakespeare.Text + +import Language.MessagePack.IDL +import Language.MessagePack.IDL.Check main :: IO () main = hspec $ do @@ -7,8 +17,12 @@ main = hspec $ do pending describe "checker" $ do - it "can check xxx..." $ do - pending + it "find multiple decl of types" $ + let res = check (parseIDL [st| +message hoge {} +message hoge {} +|]) + in isLeft res describe "generator" $ do describe "haskell" $ do @@ -16,3 +30,13 @@ main = hspec $ do pending it "can communicate reference server" $ do pending + +-- Currently, peggy's QQ generator seems not to work correctly. +-- So impl parse function. +parseIDL :: T.Text -> Spec +parseIDL txt = case parse idl (SrcPos "" 0 0 0) txt of + Left err -> error $ show err + Right spec -> spec + +isLeft (Left _) = True +isLeft _ = False From 96dacc8e742950b8af801034fdfbd67094b135f8 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Wed, 20 Jun 2012 20:23:08 +0900 Subject: [PATCH 4/8] impl checker --- msgpack-idl/Language/MessagePack/IDL/Check.hs | 70 +++++++++++++++---- msgpack-idl/test/test.hs | 22 ++++-- 2 files changed, 73 insertions(+), 19 deletions(-) diff --git a/msgpack-idl/Language/MessagePack/IDL/Check.hs b/msgpack-idl/Language/MessagePack/IDL/Check.hs index 54c5191..8157748 100644 --- a/msgpack-idl/Language/MessagePack/IDL/Check.hs +++ b/msgpack-idl/Language/MessagePack/IDL/Check.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} module Language.MessagePack.IDL.Check ( @@ -12,6 +12,7 @@ import Control.Monad.Error import Data.Data import Data.Lens.Lazy import Data.Lens.Template +import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T @@ -39,20 +40,59 @@ instance Error TcError where type TcM = StateT TcEnv (Either TcError) check :: Spec -> Either TcError () -check decls = - case execStateT (mapM_ genTypes decls) emptyEnv of - Left err -> Left err - Right ts -> Right () +check decls = evalStateT (check' decls) emptyEnv -genTypes :: Decl -> TcM () -genTypes decl = case decl of +check' :: Spec -> TcM () +check' decls = do + mapM_ getTypes decls + mapM_ typeCheck decls + +getTypes :: Decl -> TcM () +getTypes decl = case decl of MPMessage {..} -> - focus envTypes $ do - mb <- access $ mapLens msgName - when (isJust mb) $ - throwError $ TcError [st|message "#{msgName}" is already defined|] - mapLens msgName ~= Just undefined - return () - - _ -> do + addType msgName undefined + + MPException {..} -> + undefined + + MPType {..} -> + addType tyName tyType + + MPEnum {..} -> + undefined + + MPService {..} -> + return () + +addType :: T.Text -> Type -> TcM () +addType name typ = do + focus envTypes $ do + mb <- access $ mapLens name + when (isJust mb) $ + throwError $ TcError [st|message "#{name}" is already defined|] + mapLens name ~= Just typ return () + +typeCheck :: Decl -> TcM () +typeCheck decl = case decl of + MPMessage {..} -> do + -- Check each field + mapM_ (checkField msgParam) msgFields + -- Are ids unique? + checkIf "field ids are not unique" (checkUnique $ map fldId msgFields) + -- Are names unique? + checkIf "field names are not unique" (checkUnique $ map fldName msgFields) + -- TODO: type check literal + return () + + _ -> undefined + +checkUnique :: Eq a => [a] -> Bool +checkUnique ls = length ls == length (nub ls) + +checkField :: [T.Text] -> Field -> TcM () +checkField = undefined + +checkIf :: T.Text -> Bool -> TcM () +checkIf msg b = + when (not b) $ throwError $ TcError msg diff --git a/msgpack-idl/test/test.hs b/msgpack-idl/test/test.hs index 4c58d07..420a57d 100644 --- a/msgpack-idl/test/test.hs +++ b/msgpack-idl/test/test.hs @@ -17,12 +17,23 @@ main = hspec $ do pending describe "checker" $ do - it "find multiple decl of types" $ - let res = check (parseIDL [st| + it "find multiple decl of types" $ do + checkIDL "multiple msg" [st| message hoge {} message hoge {} -|]) - in isLeft res +|] + checkIDL "mixed" [st| +message hoge {} +exception hoge {} +|] + + it "find nub id" $ + checkIDL "message ids" [st| +message hoge { + 0: string hoge + 0: string moge +} +|] describe "generator" $ do describe "haskell" $ do @@ -31,6 +42,9 @@ message hoge {} it "can communicate reference server" $ do pending +checkIDL :: String -> T.Text -> Assertion +checkIDL msg = assertBool msg . isLeft . check . parseIDL + -- Currently, peggy's QQ generator seems not to work correctly. -- So impl parse function. parseIDL :: T.Text -> Spec From 999def82e43ce512d7f1df3c07b3b3de92905ae9 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Wed, 20 Jun 2012 21:07:44 +0900 Subject: [PATCH 5/8] impl cont. --- msgpack-idl/Language/MessagePack/IDL/Check.hs | 26 ++++++++++++++++--- msgpack-idl/test/test.hs | 10 +++++-- 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/msgpack-idl/Language/MessagePack/IDL/Check.hs b/msgpack-idl/Language/MessagePack/IDL/Check.hs index 8157748..8cc1fb4 100644 --- a/msgpack-idl/Language/MessagePack/IDL/Check.hs +++ b/msgpack-idl/Language/MessagePack/IDL/Check.hs @@ -53,7 +53,7 @@ getTypes decl = case decl of addType msgName undefined MPException {..} -> - undefined + addType excName undefined MPType {..} -> addType tyName tyType @@ -82,16 +82,34 @@ typeCheck decl = case decl of checkIf "field ids are not unique" (checkUnique $ map fldId msgFields) -- Are names unique? checkIf "field names are not unique" (checkUnique $ map fldName msgFields) - -- TODO: type check literal + -- TODO: check type of literal return () - _ -> undefined + MPException {..} -> do + -- Check each field + mapM_ (checkField excParam) excFields + -- Are ids unique? + checkIf "field ids are not unique" (checkUnique $ map fldId excFields) + -- Are names unique? + checkIf "field names are not unique" (checkUnique $ map fldName excFields) + -- TODO: check type of literal + return () + + MPType {..} -> + return () + + MPEnum {..} -> + undefined + + MPService {..} -> do + -- TODO: + undefined checkUnique :: Eq a => [a] -> Bool checkUnique ls = length ls == length (nub ls) checkField :: [T.Text] -> Field -> TcM () -checkField = undefined +checkField _ _ = return () checkIf :: T.Text -> Bool -> TcM () checkIf msg b = diff --git a/msgpack-idl/test/test.hs b/msgpack-idl/test/test.hs index 420a57d..3765a8d 100644 --- a/msgpack-idl/test/test.hs +++ b/msgpack-idl/test/test.hs @@ -27,12 +27,18 @@ message hoge {} exception hoge {} |] - it "find nub id" $ - checkIDL "message ids" [st| + it "find nub id" $ do + checkIDL "conflict ids" [st| message hoge { 0: string hoge 0: string moge } +|] + checkIDL "conflict names" [st| +message hoge { + 0: string hoge + 2: string hoge +} |] describe "generator" $ do From 9a5b0325312361a1f1de98a69bf1cc63e9cc0ba8 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Fri, 29 Jun 2012 20:59:14 +0900 Subject: [PATCH 6/8] implementing desugar --- msgpack-idl/Language/MessagePack/IDL/Check.hs | 1 + .../Language/MessagePack/IDL/Desugar.hs | 59 +++++++++++++++++++ .../Language/MessagePack/IDL/Syntax.hs | 3 + 3 files changed, 63 insertions(+) create mode 100644 msgpack-idl/Language/MessagePack/IDL/Desugar.hs diff --git a/msgpack-idl/Language/MessagePack/IDL/Check.hs b/msgpack-idl/Language/MessagePack/IDL/Check.hs index 8cc1fb4..5d7e4e4 100644 --- a/msgpack-idl/Language/MessagePack/IDL/Check.hs +++ b/msgpack-idl/Language/MessagePack/IDL/Check.hs @@ -93,6 +93,7 @@ typeCheck decl = case decl of -- Are names unique? checkIf "field names are not unique" (checkUnique $ map fldName excFields) -- TODO: check type of literal + -- TODO: check super type is also an exception, and do not loop. return () MPType {..} -> diff --git a/msgpack-idl/Language/MessagePack/IDL/Desugar.hs b/msgpack-idl/Language/MessagePack/IDL/Desugar.hs new file mode 100644 index 0000000..4b0b532 --- /dev/null +++ b/msgpack-idl/Language/MessagePack/IDL/Desugar.hs @@ -0,0 +1,59 @@ +module Language.MessagePack.IDL.Desugar ( + desugar, + ) where + +import Control.Monad.Identity +import Control.Monad.State +import qualified Data.Text as T + +import Language.MessagePack.IDL.Syntax + +type DsM = StateT () Identity + +type CoreSpec = [CoreDecl] + +data CoreDecl + = CMessage + { cmsgName :: T.Text + , cmsgParam :: [T.Text] + , cmsgFields :: [CoreField] + , cmsgIsException :: Maybe T.Text + } + | CType + { ctyName :: T.Text + , ctyType :: CoreType + } + + | CService + { cserviceName :: T.Text + , cserviceVersion :: Int + , serviceMethods :: [CoreMethod] + } + +data CoreMethod + = CMethod + { cmethodName :: T.Text + , cmethodVersion :: Int + , cmethodRetType :: CoreType + , cmethodArgs :: [CoreField] + } + +data CoreType + = CInt Bool Int + | CFloat Bool + | CBool + | CRaw + | CString + | CObject + | CVoid + + | CNullable CoreType + | CList CoreType + | CMap CoreType + | CTyple [CoreType] + | CUserDef T.Text [CoreType] [CoreField] + +data CoreField = CoreField + +desugar :: Spec -> DsM CoreSpec +desugar = undefined diff --git a/msgpack-idl/Language/MessagePack/IDL/Syntax.hs b/msgpack-idl/Language/MessagePack/IDL/Syntax.hs index 44ad898..a80a853 100644 --- a/msgpack-idl/Language/MessagePack/IDL/Syntax.hs +++ b/msgpack-idl/Language/MessagePack/IDL/Syntax.hs @@ -31,6 +31,9 @@ data Decl , serviceVersion :: Maybe Int , serviceMethods :: [Method] } + | MPImport + { importFile :: T.Text + } deriving (Eq, Show, Data, Typeable) data Field From 7f490f148cfc246a6ed10e2eb3adad123a384c32 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Thu, 26 Jul 2012 01:06:10 +0900 Subject: [PATCH 7/8] impl desugar --- .../Language/MessagePack/IDL/Desugar.hs | 121 +++++++++--------- 1 file changed, 62 insertions(+), 59 deletions(-) diff --git a/msgpack-idl/Language/MessagePack/IDL/Desugar.hs b/msgpack-idl/Language/MessagePack/IDL/Desugar.hs index 4b0b532..b5791ea 100644 --- a/msgpack-idl/Language/MessagePack/IDL/Desugar.hs +++ b/msgpack-idl/Language/MessagePack/IDL/Desugar.hs @@ -1,59 +1,62 @@ -module Language.MessagePack.IDL.Desugar ( - desugar, - ) where - -import Control.Monad.Identity -import Control.Monad.State -import qualified Data.Text as T - -import Language.MessagePack.IDL.Syntax - -type DsM = StateT () Identity - -type CoreSpec = [CoreDecl] - -data CoreDecl - = CMessage - { cmsgName :: T.Text - , cmsgParam :: [T.Text] - , cmsgFields :: [CoreField] - , cmsgIsException :: Maybe T.Text - } - | CType - { ctyName :: T.Text - , ctyType :: CoreType - } - - | CService - { cserviceName :: T.Text - , cserviceVersion :: Int - , serviceMethods :: [CoreMethod] - } - -data CoreMethod - = CMethod - { cmethodName :: T.Text - , cmethodVersion :: Int - , cmethodRetType :: CoreType - , cmethodArgs :: [CoreField] - } - -data CoreType - = CInt Bool Int - | CFloat Bool - | CBool - | CRaw - | CString - | CObject - | CVoid - - | CNullable CoreType - | CList CoreType - | CMap CoreType - | CTyple [CoreType] - | CUserDef T.Text [CoreType] [CoreField] - -data CoreField = CoreField - -desugar :: Spec -> DsM CoreSpec -desugar = undefined +module Language.MessagePack.IDL.Desugar ( + CoreDecl(..), + CoreMethod(..), + CoreType(..), + desugar, + ) where + +import Control.Monad.Identity +import Control.Monad.State +import qualified Data.Text as T + +import Language.MessagePack.IDL.Syntax + +type DsM = StateT () Identity + +type CoreSpec = [CoreDecl] + +data CoreDecl + = CMessage + { cmsgName :: T.Text + , cmsgParam :: [T.Text] + , cmsgFields :: [CoreField] + , cmsgIsException :: Maybe T.Text + } + | CType + { ctyName :: T.Text + , ctyType :: CoreType + } + + | CService + { cserviceName :: T.Text + , cserviceVersion :: Int + , serviceMethods :: [CoreMethod] + } + +data CoreMethod + = CMethod + { cmethodName :: T.Text + , cmethodVersion :: Int + , cmethodRetType :: CoreType + , cmethodArgs :: [CoreField] + } + +data CoreType + = CInt Bool Int + | CFloat Bool + | CBool + | CRaw + | CString + | CObject + | CVoid + + | CNullable CoreType + | CList CoreType + | CMap CoreType + | CTyple [CoreType] + | CUserDef T.Text [CoreType] [CoreField] + +data CoreField = CoreField + +desugar :: Spec -> DsM CoreSpec +desugar = undefined From 2177bd644d6b9a2bf4e58257418f27cfb0049954 Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Mon, 15 Oct 2012 17:17:59 +0900 Subject: [PATCH 8/8] merge --- .../Language/MessagePack/IDL/CodeGen/Cpp.hs | 6 +- .../MessagePack/IDL/CodeGen/Erlang.hs | 187 +++++++++++++ .../Language/MessagePack/IDL/CodeGen/Java.hs | 24 +- .../Language/MessagePack/IDL/CodeGen/Ruby.hs | 14 +- msgpack-idl/exec/{main.hs => Main.hs} | 264 +++++++++--------- msgpack-idl/test/test.hs | 21 ++ 6 files changed, 368 insertions(+), 148 deletions(-) create mode 100644 msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs rename msgpack-idl/exec/{main.hs => Main.hs} (87%) diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs index 96f71e7..5f1e5d5 100644 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs +++ b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs @@ -45,7 +45,7 @@ generate Config {..} spec = do [lt|#include |] | otherwise = [lt|#include |] - + LT.writeFile (name ++ "_types.hpp") $ templ configFilePath once "TYPES" [lt| #include #include @@ -77,7 +77,7 @@ genTypeDecl _ MPMessage {..} = genTypeDecl _ MPException {..} = genMsg excName excFields True - + genTypeDecl _ MPType { .. } = [lt| typedef #{genType tyType} #{tyName}; @@ -93,7 +93,7 @@ struct #{name}#{e} { public: #{destructor} - MSGPACK_DEFINE(#{T.intercalate ", " fs}); + MSGPACK_DEFINE(#{T.intercalate ", " fs}); #{LT.concat fields} }; |] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs new file mode 100644 index 0000000..0286c70 --- /dev/null +++ b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} + +module Language.MessagePack.IDL.CodeGen.Erlang ( + 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 + } + deriving (Show, Eq) + +generate:: Config -> Spec -> IO () +generate Config {..} spec = do + let name = takeBaseName configFilePath + once = map toUpper name + + headerFile = name ++ "_types.hrl" + + LT.writeFile (headerFile) $ templ configFilePath once "TYPES" [lt| +-ifndef(#{once}). +-define(#{once}, 1). + +-type mp_string() :: binary(). + +#{LT.concat $ map (genTypeDecl name) spec } + +-endif. +|] + + LT.writeFile (name ++ "_server.tmpl.erl") $ templ configFilePath once "SERVER" [lt| + +-module(#{name}_server). +-author('@msgpack-idl'). + +-include("#{headerFile}"). + +#{LT.concat $ map genServer spec} +|] + + LT.writeFile (name ++ "_client.erl") [lt| +% This file is automatically generated by msgpack-idl. +-module(#{name}_client). +-author('@msgpack-idl'). + +-include("#{headerFile}"). +-export([connect/3, close/1]). + +#{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| +-type #{tyName}() :: #{genType tyType}. +|] + +genTypeDecl _ _ = "" + +genMsg name flds isExc = + let fields = map f flds + in [lt| +-type #{name}() :: [ + #{LT.intercalate "\n | " fields} + ]. % #{e} +|] + where + e = if isExc then [lt| (exception)|] else "" + f Field {..} = [lt|#{genType fldType} % #{fldName}|] + +sortField flds = + flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> + find ((==ix). fldId) flds + +makeExport i Function {..} = + let j = i + length methodArgs in + [lt|#{methodName}/#{show j}|] +makeExport _ _ = "" + + +genServer :: Decl -> LT.Text +genServer MPService {..} = [lt| + +-export([#{LT.intercalate ", " $ map (makeExport 0) serviceMethods}]). + +#{LT.concat $ map genSetMethod serviceMethods} + +|] + where + genSetMethod Function {..} = + let typs = map (genType . maybe TVoid fldType) $ sortField methodArgs + args = map f methodArgs + f Field {..} = [lt|#{capitalize0 fldName}|] + capitalize0 str = T.cons (toUpper $ T.head str) (T.tail str) + + in [lt| +-spec #{methodName}(#{LT.intercalate ", " typs}) -> #{genType methodRetType}. +#{methodName}(#{LT.intercalate ", " args}) -> + Reply = <<"ok">>, % write your code here + Reply. +|] + genSetMethod _ = "" + +genServer _ = "" + +genClient :: Decl -> LT.Text +genClient MPService {..} = [lt| + +-export([#{LT.intercalate ", " $ map (makeExport 1) serviceMethods}]). + +-spec connect(inet:ip_address(), inet:port_number(), [proplists:property()]) -> {ok, pid()} | {error, any()}. +connect(Host,Port,Options)-> + msgpack_rpc_client:connect(tcp,Host,Port,Options). + +-spec close(pid())-> ok. +close(Pid)-> + msgpack_rpc_client:close(Pid). + +#{LT.concat $ map genMethodCall serviceMethods} +|] + where + genMethodCall Function {..} = + let typs = map (genType . maybe TVoid fldType) $ sortField methodArgs + args = map f methodArgs + f Field {..} = [lt|#{capitalize0 fldName}|] + capitalize0 str = T.cons (toUpper $ T.head str) (T.tail str) + in [lt| +-spec #{methodName}(pid(), #{LT.intercalate ", " typs}) -> #{genType methodRetType}. +#{methodName}(Pid, #{LT.intercalate ", " args}) -> + msgpack_rpc_client:call(Pid, #{methodName}, [#{LT.intercalate ", " args}]). +|] + 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 "non_neg_integer" else "integer" :: LT.Text in + [lt|#{base}()|] +genType (TFloat _) = + [lt|float()|] +genType TBool = + [lt|boolean()|] +genType TRaw = + [lt|binary()|] +genType TString = + [lt|mp_string()|] +genType (TList typ) = + [lt|list(#{genType typ})|] +genType (TMap typ1 typ2) = + [lt|list({#{genType typ1}, #{genType typ2}})|] +genType (TUserDef className params) = + [lt|#{className}()|] +genType (TTuple ts) = + -- TODO: FIX + foldr1 (\t1 t2 -> [lt|{#{t1}, #{t2}}|]) $ map genType ts +genType TObject = + [lt|term()|] +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} + +#{content}|] diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs index 979e2ef..17a3d3f 100644 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs +++ b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Java.hs @@ -51,7 +51,7 @@ public class Tuple { |] genImport :: FilePath -> Decl -> LT.Text -genImport packageName MPMessage {..} = +genImport packageName MPMessage {..} = [lt|import #{packageName}.#{formatClassNameT msgName}; |] genImport _ _ = "" @@ -89,7 +89,7 @@ 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 +resolveTypeAlias alias ty = let fixedAlias = resolveTypeAlias alias in case ty of TNullable t -> TNullable $ fixedAlias t @@ -100,7 +100,7 @@ resolveTypeAlias alias ty = let fixedAlias = resolveTypeAlias alias in TTuple ts -> TTuple $ map fixedAlias ts TUserDef className params -> - case lookup className alias of + case lookup className alias of Just resolvedType -> resolvedType Nothing -> TUserDef className (map fixedAlias params) otherwise -> ty @@ -111,7 +111,7 @@ genInit Field {..} = case fldDefault of Just defaultVal -> [lt| #{fldName} = #{genLiteral defaultVal};|] genDecl :: Field -> LT.Text -genDecl Field {..} = +genDecl Field {..} = [lt| public #{genType fldType} #{fldName}; |] @@ -130,13 +130,13 @@ public class #{formatClassNameT excName} #{params}{ |] where params = if null excParam then "" else [lt|<#{T.intercalate ", " excParam}>|] - super = case excSuper of + super = case excSuper of Just x -> [st|extends #{x}|] Nothing -> "" genException _ _ = return () genClient :: [(T.Text, Type)] -> Config -> Decl -> IO() -genClient alias Config {..} MPService {..} = do +genClient alias Config {..} MPService {..} = do let resolvedServiceMethods = map (resolveMethodAlias alias) serviceMethods hashMapImport | not $ null [() | TMap _ _ <- map methodRetType resolvedServiceMethods ] = [lt|import java.util.HashMap;|] | otherwise = "" @@ -188,7 +188,7 @@ public class #{className} { genClient _ _ _ = return () genSignature :: Method -> LT.Text -genSignature Function {..} = +genSignature Function {..} = [lt| #{genType methodRetType} #{methodName}(#{args}); |] where @@ -208,8 +208,8 @@ pack fields converter= 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 + map (\sIx -> case sIx of + Nothing -> converter Nothing Just i -> converter $ Just (fields!!i) ) sortedIxs genVal :: Maybe Field -> T.Text @@ -233,7 +233,7 @@ genLiteral LNull = [lt|null|] genLiteral (LString s) = [lt|#{show s}|] associateBracket :: [LT.Text] -> LT.Text -associateBracket msgParam = +associateBracket msgParam = if null msgParam then "" else [lt|<#{LT.intercalate ", " msgParam}>|] @@ -269,8 +269,8 @@ genType TVoid = [lt|void|] genTypeWithContext :: Spec -> Type -> LT.Text -genTypeWithContext spec t = case t of - (TUserDef className params) -> +genTypeWithContext spec t = case t of + (TUserDef className params) -> case lookup className $ map genAlias $ filter isMPType spec of Just x -> genType x Nothing -> "" diff --git a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs index 3e10883..62de192 100644 --- a/msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs +++ b/msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs @@ -30,13 +30,13 @@ generate Config {..} spec = do setCurrentDirectory (takeBaseName configFilePath); let mods = LT.splitOn "::" $ LT.pack configModule - + LT.writeFile "types.rb" $ [lt| require 'rubygems' require 'msgpack/rpc' #{genModule mods $ LT.concat $ map (genTypeDecl "") spec } |] - + LT.writeFile ("client.rb") $ templ configFilePath [lt| require 'rubygems' require 'msgpack/rpc' @@ -61,7 +61,7 @@ genTypeDecl _ MPMessage {..} = genTypeDecl _ MPException {..} = genMsg excName excFields True - + genTypeDecl _ _ = "" genMsg :: T.Text -> [Field] -> Bool -> LT.Text @@ -70,7 +70,7 @@ class #{capitalizeT name}#{deriveError} def initialize(#{T.intercalate ", " fs}) #{LT.intercalate "\n " $ map makeSubst fs} end - def to_tuple + def to_tuple [#{LT.intercalate ",\n " $ map make_tuple flds}] end def to_msgpack(out = '') @@ -88,7 +88,7 @@ end sorted_flds = sortField flds fs = map (maybe undefined fldName) sorted_flds -- afs = LT.intercalate ",\n " $ map make_tuple flds - make_tuple Field {..} = + make_tuple Field {..} = [lt|#{toTuple True fldType fldName}|] deriveError = if isExc then [lt| < StandardError|] else "" make_arg Field {..} = @@ -99,7 +99,7 @@ makeSubst :: T.Text -> LT.Text makeSubst fld = [lt| @#{fld} = #{fld} |] toTuple :: Bool -> Type -> T.Text -> LT.Text -toTuple _ (TTuple ts) name = +toTuple _ (TTuple ts) name = let elems = map (f name) (zip [0..] ts) in [lt| [#{LT.concat elems}] |] where @@ -130,7 +130,7 @@ fromTuple TRaw name = [lt|#{name}|] fromTuple TString name = [lt|#{name}|] fromTuple (TList typ) name = [lt|#{name}.map { |x| #{fromTuple typ "x"} }|] - + fromTuple (TMap typ1 typ2) name = [lt|#{name}.each_with_object({}) {|(k,v),h| h[#{fromTuple typ1 "k"}] = #{fromTuple typ2 "v"} }|] diff --git a/msgpack-idl/exec/main.hs b/msgpack-idl/exec/Main.hs similarity index 87% rename from msgpack-idl/exec/main.hs rename to msgpack-idl/exec/Main.hs index b65ba63..85f1232 100644 --- a/msgpack-idl/exec/main.hs +++ b/msgpack-idl/exec/Main.hs @@ -1,126 +1,138 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RecordWildCards #-} - -import Data.Version -import System.Console.CmdArgs -import Text.Peggy - -import Language.MessagePack.IDL -import Language.MessagePack.IDL.Internal -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.Python as Python -import qualified Language.MessagePack.IDL.CodeGen.Perl as Perl - -import Paths_msgpack_idl - -data MPIDL - = Haskell - { output_dir :: FilePath - , module_name :: String - , filepath :: FilePath - } - | 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 - } - | Python - { 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 - { output_dir = def - , module_name = "" - , filepath = def &= argPos 0 - } - , 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 - } - , Python - { output_dir = def - , filepath = def &= argPos 0 - } - , 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 - withDirectory (output_dir conf) $ do - case conf of - Cpp {..} -> do - Cpp.generate (Cpp.Config filepath namespace pficommon) spec - - Haskell {..} -> do - Haskell.generate (Haskell.Config filepath) spec - - Java {..} -> do - Java.generate (Java.Config filepath package) spec - - Perl {..} -> do - Perl.generate (Perl.Config filepath namespace) spec - - Php {..} -> do - Php.generate (Php.Config filepath) spec - - Python {..} -> do - Python.generate (Python.Config filepath) spec - - Ruby {..} -> do - Ruby.generate (Ruby.Config filepath modules) spec +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} + +import Data.Version +import System.Console.CmdArgs +import Text.Peggy + +import Language.MessagePack.IDL +import Language.MessagePack.IDL.Internal +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.Python as Python +import qualified Language.MessagePack.IDL.CodeGen.Perl as Perl +import qualified Language.MessagePack.IDL.CodeGen.Erlang as Erlang + +import Paths_msgpack_idl + +data MPIDL + = Haskell + { output_dir :: FilePath + , module_name :: String + , filepath :: FilePath + } + | 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 + } + | Python + { output_dir :: FilePath + , filepath :: FilePath + } + | Perl + { output_dir :: FilePath + , namespace :: String + , filepath :: FilePath } + | Erlang + { output_dir :: FilePath + , filepath :: FilePath } + deriving (Show, Eq, Data, Typeable) + +main :: IO () +main = do + conf <- cmdArgs $ + modes [ Haskell + { output_dir = def + , module_name = "" + , filepath = def &= argPos 0 + } + , 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 + } + , Python + { output_dir = def + , filepath = def &= argPos 0 + } + , Perl + { output_dir = def + , namespace = "msgpack" + , filepath = def &= argPos 0 + } + , Erlang + { output_dir = def + , 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 + withDirectory (output_dir conf) $ do + case conf of + Cpp {..} -> do + Cpp.generate (Cpp.Config filepath namespace pficommon) spec + + Haskell {..} -> do + Haskell.generate (Haskell.Config filepath) spec + + Java {..} -> do + Java.generate (Java.Config filepath package) spec + + Perl {..} -> do + Perl.generate (Perl.Config filepath namespace) spec + + Php {..} -> do + Php.generate (Php.Config filepath) spec + + Python {..} -> do + Python.generate (Python.Config filepath) spec + + Ruby {..} -> do + Ruby.generate (Ruby.Config filepath modules) spec + + Erlang {..} -> do + Erlang.generate (Erlang.Config filepath) spec + diff --git a/msgpack-idl/test/test.hs b/msgpack-idl/test/test.hs index 3765a8d..fe994e9 100644 --- a/msgpack-idl/test/test.hs +++ b/msgpack-idl/test/test.hs @@ -1,3 +1,4 @@ +<<<<<<< Updated upstream {-# LANGUAGE QuasiQuotes #-} import Data.ListLike.Text () import qualified Data.Text as T @@ -60,3 +61,23 @@ parseIDL txt = case parse idl (SrcPos "" 0 0 0) txt of isLeft (Left _) = True isLeft _ = False +======= +import Test.Hspec.Monadic + +main :: IO () +main = hspecX $ do + describe "parser" $ do + it "can parse xxx..." $ do + pending + + describe "checker" $ do + it "can check xxx..." $ do + pending + + describe "generator" $ do + describe "haskell" $ do + it "can generate client" $ do + pending + it "can communicate reference server" $ do + pending +>>>>>>> Stashed changes