{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cpp -- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module FFICXX.Generate.Code.Cpp where import Data.Char import Data.List (intercalate) import Data.Monoid ((<>)) -- import FFICXX.Generate.Code.Primitive (accessorCFunSig ,argsToCallString ,argsToString ,argsToStringNoSelf ,castCpp2C ,castC2Cpp ,CFunSig(..) ,genericFuncArgs ,genericFuncRet ,rettypeToString ,tmplMemFuncArgToString ,tmplMemFuncRetTypeToString ,tmplAllArgsToCallString ,tmplAllArgsToString ,tmplRetTypeToString) import FFICXX.Generate.Name (aliasedFuncName ,cppFuncName ,ffiClassName ,ffiTmplFuncName ,hsTemplateMemberFunctionName) import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Generate.Util -- -- -- Class Declaration and Definition -- ---- ---- Declaration ---- ---- "Class Type Declaration" Instances genCppHeaderMacroType :: Class -> String genCppHeaderMacroType c = let tmpl = "// Opaque type definition for $classname \n\ \typedef struct ${classname}_tag ${classname}_t; \n\ \typedef ${classname}_t * ${classname}_p; \n\ \typedef ${classname}_t const* const_${classname}_p; \n" in subst tmpl (context [ ("classname", ffiClassName c) ]) ---- "Class Declaration Virtual" Declaration genCppHeaderMacroVirtual :: Class -> String genCppHeaderMacroVirtual aclass = let tmpl = "#undef ${classname}_DECL_VIRT \n#define ${classname}_DECL_VIRT(Type) \\\n${funcdecl}" funcDeclStr = (funcsToDecls aclass) . virtualFuncs . class_funcs $ aclass in subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) ) , ("funcdecl" , funcDeclStr ) ]) ---- "Class Declaration Non-Virtual" Declaration genCppHeaderMacroNonVirtual :: Class -> String genCppHeaderMacroNonVirtual c = let tmpl = "#undef ${classname}_DECL_NONVIRT \n#define ${classname}_DECL_NONVIRT(Type) \\\n$funcdecl" declBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c)) , ("funcdecl" , funcDeclStr ) ]) funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc) . class_funcs $ c in declBodyStr ---- "Class Declaration Accessor" Declaration genCppHeaderMacroAccessor :: Class -> String genCppHeaderMacroAccessor c = let tmpl = "#undef ${classname}_DECL_ACCESSOR\n#define ${classname}_DECL_ACCESSOR(Type)\\\n$funcdecl" declBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c)) , ("funcdecl" , funcDeclStr ) ]) funcDeclStr = accessorsToDecls (class_vars c) in declBodyStr ---- "Class Declaration Virtual/NonVirtual/Accessor" Instances genCppHeaderInstVirtual :: (Class,Class) -> String genCppHeaderInstVirtual (p,c) = let strc = map toUpper (ffiClassName p) in strc<>"_DECL_VIRT(" <> ffiClassName c <> ");\n" genCppHeaderInstNonVirtual :: Class -> String genCppHeaderInstNonVirtual c = let strx = map toUpper (ffiClassName c) in strx<>"_DECL_NONVIRT(" <> ffiClassName c <> ");\n" genCppHeaderInstAccessor :: Class -> String genCppHeaderInstAccessor c = let strx = map toUpper (ffiClassName c) in strx<>"_DECL_ACCESSOR(" <> ffiClassName c <> ");\n" ---- ---- Definition ---- ---- "Class Definition Virtual" Declaration genCppDefMacroVirtual :: Class -> String genCppDefMacroVirtual aclass = let tmpl = "#undef ${classname}_DEF_VIRT\n#define ${classname}_DEF_VIRT(Type)\\\n$funcdef" defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) ) , ("funcdef" , funcDefStr ) ]) funcDefStr = (funcsToDefs aclass) . virtualFuncs . class_funcs $ aclass in defBodyStr ---- "Class Definition NonVirtual" Declaration genCppDefMacroNonVirtual :: Class -> String genCppDefMacroNonVirtual aclass = let tmpl = "#undef ${classname}_DEF_NONVIRT\n#define ${classname}_DEF_NONVIRT(Type)\\\n$funcdef" defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) ) , ("funcdef" , funcDefStr ) ]) funcDefStr = (funcsToDefs aclass) . filter (not.isVirtualFunc) . class_funcs $ aclass in defBodyStr ---- Define Macro to provide Accessor C-C++ shim code for a class genCppDefMacroAccessor :: Class -> String genCppDefMacroAccessor c = let tmpl = "#undef ${classname}_DEF_ACCESSOR\n#define ${classname}_DEF_ACCESSOR(Type)\\\n$funcdef" defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c)) , ("funcdef" , funcDefStr ) ]) funcDefStr = accessorsToDefs (class_vars c) in defBodyStr ---- Define Macro to provide TemplateMemberFunction C-C++ shim code for a class genCppDefMacroTemplateMemberFunction :: Class -> TemplateMemberFunction -> String genCppDefMacroTemplateMemberFunction c f = subst tmpl ctxt where tmpl = "#define ${macroname}(Type) \\\n\ \ extern \"C\" { \\\n\ \ $decl; \\\n\ \ } \\\n\ \ inline $defn \\\n\ \ auto a_${macroname}_##Type = ${macroname}_##Type ;\n" ctxt = context [ ("macroname", hsTemplateMemberFunctionName c f) , ("decl" , tmplMemberFunToDecl c f) , ("defn" , tmplMemberFunToDef c f) ] ---- Invoke Macro to define Virtual/NonVirtual method for a class genCppDefInstVirtual :: (Class,Class) -> String genCppDefInstVirtual (p,c) = let strc = map toUpper (ffiClassName p) in strc<>"_DEF_VIRT(" <> ffiClassName c <> ")\n" genCppDefInstNonVirtual :: Class -> String genCppDefInstNonVirtual c = subst "${capitalclassname}_DEF_NONVIRT(${classname})" (context [ ("capitalclassname", toUppers (ffiClassName c)) , ("classname" , ffiClassName c ) ]) genCppDefInstAccessor :: Class -> String genCppDefInstAccessor c = subst "${capitalclassname}_DEF_ACCESSOR(${classname})" (context [ ("capitalclassname", toUppers (ffiClassName c)) , ("classname" , ffiClassName c ) ]) ----------------- genAllCppHeaderInclude :: ClassImportHeader -> String genAllCppHeaderInclude header = intercalateWith connRet (\x->"#include \""<>x<>"\"") $ map unHdrName (cihIncludedHPkgHeadersInCPP header <> cihIncludedCPkgHeaders header) ---- ------------------------- -- TOP LEVEL FUNCTIONS -- ------------------------- genTopLevelFuncCppHeader :: TopLevelFunction -> String genTopLevelFuncCppHeader TopLevelFunction {..} = subst "$returntype $funcname ( $args );" (context [ ("returntype", rettypeToString toplevelfunc_ret ) , ("funcname" , "TopLevel_" <> maybe toplevelfunc_name id toplevelfunc_alias) , ("args" , argsToStringNoSelf toplevelfunc_args ) ]) genTopLevelFuncCppHeader TopLevelVariable {..} = subst "$returntype $funcname ( );" (context [ ("returntype", rettypeToString toplevelvar_ret ) , ("funcname" , "TopLevel_" <> maybe toplevelvar_name id toplevelvar_alias) ]) genTopLevelFuncCppDefinition :: TopLevelFunction -> String genTopLevelFuncCppDefinition TopLevelFunction {..} = let tmpl = "$returntype $funcname ( $args ) { \n $funcbody\n}" callstr = toplevelfunc_name <> "(" <> argsToCallString toplevelfunc_args <> ")" funcDefStr = returnCpp False (toplevelfunc_ret) callstr in subst tmpl (context [ ("returntype", rettypeToString toplevelfunc_ret ) , ("funcname" , "TopLevel_" <> maybe toplevelfunc_name id toplevelfunc_alias) , ("args" , argsToStringNoSelf toplevelfunc_args ) , ("funcbody" , funcDefStr ) ]) genTopLevelFuncCppDefinition TopLevelVariable {..} = let tmpl = "$returntype $funcname ( ) { \n $funcbody\n}" callstr = toplevelvar_name funcDefStr = returnCpp False (toplevelvar_ret) callstr in subst tmpl (context [ ("returntype", rettypeToString toplevelvar_ret ) , ("funcname" , "TopLevel_" <> maybe toplevelvar_name id toplevelvar_alias) , ("funcbody" , funcDefStr ) ]) genTmplFunCpp :: Bool -- ^ is for simple type? -> TemplateClass -> TemplateFunction -> String genTmplFunCpp b t@TmplCls {..} f = subst tmpl ctxt where tmpl = "#define ${tname}_${fname}${suffix}(Type) \\\n\ \ extern \"C\" { \\\n\ \ $decl; \\\n\ \ } \\\n\ \ inline $defn \\\n\ \ auto a_${tname}_${fname}_ ## Type = ${tname}_${fname}_ ## Type ;\n" ctxt = context $ (("suffix",if b then "_s" else ""):) $ [ ("tname" , tclass_name ) , ("fname" , ffiTmplFuncName f) , ("decl" , tmplFunToDecl b t f ) , ("defn" , tmplFunToDef b t f ) ] genTmplClassCpp :: Bool -- ^ is for simple type -> TemplateClass -> [TemplateFunction] -> String genTmplClassCpp b TmplCls {..} fs = subst tmpl ctxt where tmpl = "#define ${tname}_instance${suffix}(Type) \\\n\ \$macro\n" suffix = if b then "_s" else "" ctxt = context [ ("tname" , tclass_name ) , ("suffix" , suffix ) , ("macro" , macro ) ] tname = tclass_name macro1 f@TFun {..} = " " <> tname<> "_" <> ffiTmplFuncName f <> suffix <> "(Type) \\" macro1 f@TFunNew {..} = " " <> tname<> "_" <> ffiTmplFuncName f <> "(Type) \\" macro1 TFunDelete = " " <> tname<> "_delete(Type) \\" macro = intercalateWith connRet macro1 fs returnCpp :: Bool -- ^ for simple type -> Types -> String -- ^ call string -> String returnCpp b ret callstr = case ret of Void -> callstr <> ";" SelfType -> "return to_nonconst((Type *)" <> callstr <> ") ;" CT (CRef _) _ -> "return (&("<>callstr<>"));" CT _ _ -> "return "<>callstr<>";" CPT (CPTClass c') _ -> "return to_nonconst<"<>str<>"_t,"<>str <>">(("<>str<>"*)"<>callstr<>");" where str = ffiClassName c' CPT (CPTClassRef c') _ -> "return to_nonconst<"<>str<>"_t,"<>str <>">(&("<>callstr<>"));" where str = ffiClassName c' CPT (CPTClassCopy c') _ -> "return to_nonconst<"<>str<>"_t,"<>str <>">(new "<>str<>"("<>callstr<>"));" where str = ffiClassName c' CPT (CPTClassMove c') _ -> -- TODO: check whether this is working or not. "return std::move(to_nonconst<"<>str<>"_t,"<>str <>">(&("<>callstr<>")));" where str = ffiClassName c' TemplateApp (TemplateAppInfo _ _ cpptype) -> cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); " <> "return (static_cast(r));" TemplateAppRef (TemplateAppInfo _ _ cpptype) -> cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); " <> "return (static_cast(r));" TemplateAppMove (TemplateAppInfo _ _ cpptype) -> cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); " <> "return std::move(static_cast(r));" TemplateType _ -> error "returnCpp: TemplateType" TemplateParam _ -> if b then "return (" <> callstr <> ");" else "return to_nonconst((Type *)&(" <> callstr <> ")) ;" TemplateParamPointer _ -> if b then "return (" <> callstr <> ");" else "return to_nonconst(" <> callstr <> ") ;" -- Function Declaration and Definition funcToDecl :: Class -> Function -> String funcToDecl c func | isNewFunc func || isStaticFunc func = let tmpl = "$returntype Type ## _$funcname ( $args )" in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func)) , ("funcname", aliasedFuncName c func) , ("args", argsToStringNoSelf (genericFuncArgs func)) ]) | otherwise = let tmpl = "$returntype Type ## _$funcname ( $args )" in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func)) , ("funcname", aliasedFuncName c func) , ("args", argsToString (genericFuncArgs func)) ]) funcsToDecls :: Class -> [Function] -> String funcsToDecls c = intercalateWith connSemicolonBSlash (funcToDecl c) funcToDef :: Class -> Function -> String funcToDef c func | isNewFunc func = let declstr = funcToDecl c func callstr = "(" <> argsToCallString (genericFuncArgs func) <> ")" returnstr = "Type * newp = new Type " <> callstr <> "; \\\nreturn to_nonconst(newp);" in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] | isDeleteFunc func = let declstr = funcToDecl c func returnstr = "delete (to_nonconst(p)) ; " in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] | isStaticFunc func = let declstr = funcToDecl c func callstr = cppFuncName c func <> "(" <> argsToCallString (genericFuncArgs func) <> ")" returnstr = returnCpp False (genericFuncRet func) callstr in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] | otherwise = let declstr = funcToDecl c func callstr = "TYPECASTMETHOD(Type,"<> aliasedFuncName c func <> "," <> class_name c <> ")(p)->" <> cppFuncName c func <> "(" <> argsToCallString (genericFuncArgs func) <> ")" returnstr = returnCpp False (genericFuncRet func) callstr in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] funcsToDefs :: Class -> [Function] -> String funcsToDefs c = intercalateWith connBSlash (funcToDef c) tmplFunToDecl :: Bool -> TemplateClass -> TemplateFunction -> String tmplFunToDecl b t@TmplCls {..} f@TFun {..} = subst "$ret ${tname}_${fname}_ ## Type ( $args )" (context [ ("tname", tclass_name) , ("fname", ffiTmplFuncName f) , ("args" , tmplAllArgsToString b Self t tfun_args) , ("ret" , tmplRetTypeToString b tfun_ret) ]) tmplFunToDecl b t@TmplCls {..} f@TFunNew {..} = subst "$ret ${tname}_${fname}_ ## Type ( $args )" (context [ ("tname", tclass_name) , ("fname", ffiTmplFuncName f) , ("args" , tmplAllArgsToString b NoSelf t tfun_new_args) , ("ret" , tmplRetTypeToString b (TemplateType t)) ]) tmplFunToDecl b t@TmplCls {..} TFunDelete = subst "$ret ${tname}_delete_ ## Type ( $args )" (context [ ("tname", tclass_name ) , ("args" , tmplAllArgsToString b Self t [] ) , ("ret" , "void" ) ]) tmplFunToDef :: Bool -- ^ for simple type -> TemplateClass -> TemplateFunction -> String tmplFunToDef b t@TmplCls {..} f = intercalateWith connBSlash id [declstr, " {", " "<>returnstr, " }"] where declstr = tmplFunToDecl b t f callstr = case f of TFun {..} -> "(static_cast<" <> tclass_oname <> "*>(p))->" <> tfun_oname <> "(" <> tmplAllArgsToCallString b tfun_args <> ")" TFunNew {..} -> "new " <> tclass_oname <> "(" <> tmplAllArgsToCallString b tfun_new_args <> ")" TFunDelete -> "delete (static_cast<" <> tclass_oname <> "*>(p))" returnstr = case f of TFunNew {..} -> "return static_cast("<>callstr<>");" TFunDelete -> callstr <> ";" TFun {..} -> returnCpp b (tfun_ret) callstr -- Accessor Declaration and Definition accessorToDecl :: Variable -> Accessor -> String accessorToDecl v a = let tmpl = "$returntype Type ## _$funcname ( $args )" csig = accessorCFunSig (var_type v) a in subst tmpl (context [ ("returntype", rettypeToString (cRetType csig)) , ("funcname" , var_name v <> "_" <> case a of Getter -> "get"; Setter -> "set") , ("args" , argsToString (cArgTypes csig)) ]) accessorsToDecls :: [Variable] -> String accessorsToDecls vs = let dcls = concatMap (\v -> [accessorToDecl v Getter,accessorToDecl v Setter]) vs in intercalate "; \\\n" dcls accessorToDef :: Variable -> Accessor -> String accessorToDef v a = let declstr = accessorToDecl v a varexp = "to_nonconst(p)->" <> var_name v body Getter = "return (" <> castCpp2C (var_type v) varexp <> ");" body Setter = varexp <> " = " <> castC2Cpp (var_type v) "x" -- TODO: somehow clean up this hard-coded "x". <> ";" in intercalate "\\\n" [declstr, "{", body a, "}"] accessorsToDefs :: [Variable] -> String accessorsToDefs vs = let defs = concatMap (\v -> [accessorToDef v Getter,accessorToDef v Setter]) vs in intercalate "; \\\n" defs -- Template Member Function Declaration and Definition -- TODO: Handle simple type tmplMemberFunToDecl :: Class -> TemplateMemberFunction -> String tmplMemberFunToDecl c f = subst "$ret ${macroname}_##Type ( $args )" (context [ ("macroname", hsTemplateMemberFunctionName c f) , ("args" , intercalateWith conncomma (tmplMemFuncArgToString c) ((SelfType,"p"):tmf_args f)) , ("ret" , tmplMemFuncRetTypeToString c (tmf_ret f)) ]) -- TODO: Handle simple type tmplMemberFunToDef :: Class -> TemplateMemberFunction -> String tmplMemberFunToDef c f = intercalateWith connBSlash id [ declstr , " {" , " " <> returnstr , " }" ] where declstr = tmplMemberFunToDecl c f callstr = "(to_nonconst<" <> ffiClassName c <> "," <> ffiClassName c <> "_t" <> ">(p))" <> "->" <> tmf_name f <> "" <> "(" <> tmplAllArgsToCallString False (tmf_args f) <> ")" returnstr = returnCpp False (tmf_ret f) callstr