Cpp.hs

{-# 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 _ MPEnum { ..} =
  [lt|
enum #{enumName} {
    #{genEnum enumMem}
};|]


genTypeDecl _ _ = ""

genEnum :: [(Int, T.Text)] -> LT.Text
genEnum entries = LT.intercalate ",\n    " $ map enumEntry entries
                where enumEntry (val, name) = [lt|#{name} = #{show val}|]

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]