{-# 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 System.Directory 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 dirName = joinPath $ map LT.unpack $ LT.split (== '.') $ LT.pack $ configPackage config genTuple config createDirectoryIfMissing True dirName mapM_ (genClient typeAlias config) spec mapM_ (genStruct typeAlias config) spec mapM_ (genException typeAlias 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 { public T a; public U b; }; |] genImport :: FilePath -> Decl -> LT.Text genImport packageName MPMessage {..} = [lt|import #{packageName}.#{formatClassNameT msgName}; |] genImport _ _ = "" genStruct :: [(T.Text, Type)] -> Config -> Decl -> IO() genStruct alias Config{..} MPMessage {..} = do let params = if null msgParam then "" else [lt|<#{T.intercalate ", " msgParam}>|] resolvedMsgFields = map (resolveFieldAlias alias) msgFields hashMapImport | not $ null [() | TMap _ _ <- map fldType resolvedMsgFields] = [lt|import java.util.HashMap;|] | otherwise = "" arrayListImport | not $ null [() | TList _ <- map fldType resolvedMsgFields] = [lt|import java.util.ArrayList;|] | otherwise = "" dirName = joinPath $ map LT.unpack $ LT.split (== '.') $ LT.pack configPackage fileName = dirName ++ "/" ++ (T.unpack $ formatClassNameT msgName) ++ ".java" LT.writeFile fileName $ templ configFilePath [lt| package #{configPackage}; #{hashMapImport} #{arrayListImport} import org.msgpack.MessagePack; import org.msgpack.annotation.Message; @Message 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 (resolveRetTypeAlias 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) _ -> ty resolveRetTypeAlias :: [(T.Text, Type)] -> Maybe Type -> Maybe Type resolveRetTypeAlias alias Nothing = Nothing resolveRetTypeAlias alias (Just t) = Just (resolveTypeAlias alias t) 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 :: [(T.Text, Type)] -> Config -> Decl -> IO() genException alias Config{..} MPException{..} = do LT.writeFile ( (formatClassName $ T.unpack excName) ++ ".java") $ templ configFilePath [lt| package #{configPackage}; import org.msgpack.MessagePack; import org.msgpack.annotation.Message; @Message 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 hashMapImport | not $ null [() | Just (TMap _ _) <- map methodRetType resolvedServiceMethods ] = [lt|import java.util.HashMap;|] | otherwise = "" arrayListImport | not $ null [() | Just (TList _) <- map methodRetType resolvedServiceMethods] = [lt|import java.util.ArrayList;|] | otherwise = "" dirName = joinPath $ map LT.unpack $ LT.split (== '.') $ LT.pack configPackage fileName = dirName ++ "/" ++ (T.unpack className) ++ ".java" LT.writeFile fileName $ templ configFilePath [lt| package #{configPackage}; #{hashMapImport} #{arrayListImport} 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 Nothing -> [lt| public void #{methodName}(#{args}) { iface_.#{methodName}(#{vals}); } |] Just typ -> [lt| public #{genType typ} #{methodName}(#{args}) { return iface_.#{methodName}(#{vals}); } |] genMethodCall _ = "" genClient _ _ _ = return () genSignature :: Method -> LT.Text genSignature Function {..} = [lt| #{genRetType 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|] genRetType :: Maybe Type -> LT.Text genRetType Nothing = [lt|void|] genRetType (Just t) = genType t 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 (TNullable typ) = genWrapperType typ templ :: FilePath -> LT.Text -> LT.Text templ filepath content = [lt| // This file is auto-generated from #{filepath} // *** DO NOT EDIT *** #{content} |]