hoppy-generator-0.3.1: src/Foreign/Hoppy/Generator/Language/Cpp/Internal.hs
-- This file is part of Hoppy.
--
-- Copyright 2015-2017 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, ViewPatterns #-}
-- | Internal portion of the C++ code generator.
module Foreign.Hoppy.Generator.Language.Cpp.Internal (
Generation,
generate,
generatedFiles,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (liftM, unless, when)
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
import Control.Monad.Writer (WriterT, execWriterT, runWriterT, tell)
import Control.Monad.Trans (lift)
import Data.Foldable (forM_)
#if !MIN_VERSION_base(4,8,0)
import Data.Functor ((<$))
#endif
import Data.List (intersperse)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mappend, mconcat, mempty)
#endif
import qualified Data.Set as S
import Foreign.Hoppy.Generator.Common
import Foreign.Hoppy.Generator.Language.Cpp
import Foreign.Hoppy.Generator.Spec
import Foreign.Hoppy.Generator.Types
data CoderDirection = DoDecode | DoEncode
deriving (Eq, Show)
type Generator = ReaderT Env (WriterT [Chunk] (WriterT (S.Set Include) (Either ErrorMsg)))
data Env = Env
{ envInterface :: Interface
, envModule :: Module
}
addIncludes :: [Include] -> Generator ()
addIncludes = lift . lift . tell . S.fromList
addInclude :: Include -> Generator ()
addInclude = addIncludes . (:[])
-- Have to call this addReqsM, addReqs is taken by HasReqs.
addReqsM :: Reqs -> Generator ()
addReqsM = lift . lift . tell . reqsIncludes
askInterface :: MonadReader Env m => m Interface
askInterface = liftM envInterface ask
askModule :: MonadReader Env m => m Module
askModule = liftM envModule ask
-- | Halts generation and returns the given error message.
abort :: ErrorMsg -> Generator a
abort = lift . lift . lift . Left
execGenerator :: Interface -> Module -> Maybe String -> Generator a -> Either ErrorMsg String
execGenerator interface m maybeHeaderGuardName action = do
(contents, includes) <-
(runWriterT $
-- WriterT (S.Set Include) (Either String) String:
execChunkWriterT $
-- WriterT [Chunk] (WriterT (S.Set Include) (Either String)) a:
runReaderT action $ Env interface m)
:: Either String (String, S.Set Include)
return $ execChunkWriter $ do
say "////////// GENERATED FILE, EDITS WILL BE LOST //////////\n"
forM_ maybeHeaderGuardName $ \x -> do
says ["\n#ifndef ", x, "\n"]
says ["#define ", x, "\n"]
unless (S.null includes) $ do
say "\n"
forM_ includes $ say . includeToString
say "\nextern \"C\" {\n"
say contents
say "\n} // extern \"C\"\n"
forM_ maybeHeaderGuardName $ \x ->
says ["\n#endif // ifndef ", x, "\n"]
sayFunction :: String -> [String] -> Type -> Maybe (Generator ()) -> Generator ()
sayFunction name paramNames t maybeBody = do
case t of
Internal_TFn {} -> return ()
_ -> abort $ concat ["sayFunction: A function type is required, given ", show t, "."]
say "\n" -- New top-level structure, leave a blank line.
sayVar name (Just paramNames) t
case maybeBody of
Nothing -> say ";\n"
Just body -> do
say " {\n"
body -- TODO Indent.
say "}\n"
-- | The in-memory result of generating C++ code for an interface.
data Generation = Generation
{ generatedFiles :: M.Map FilePath String
-- ^ A map from paths of generated files to the contents of those files.
-- The file paths are relative paths below the C++ generation root.
}
-- | Runs the C++ code generator against an interface.
generate :: Interface -> Either ErrorMsg Generation
generate interface =
fmap (Generation . M.fromList) $
execWriterT $
forM_ (M.elems $ interfaceModules interface) $ \m -> do
let headerGuard = concat ["HOPPY_MODULE_", interfaceName interface, "_", moduleName m]
header <- lift $ execGenerator interface m (Just headerGuard) sayModuleHeader
tell [(moduleHppPath m, header)]
source <- lift $ execGenerator interface m Nothing sayModuleSource
tell [(moduleCppPath m, source)]
sayModuleHeader :: Generator ()
sayModuleHeader = do
m <- askModule
addReqsM $ moduleReqs m
mapM_ (sayExport False) $ M.elems $ moduleExports m
iface <- askInterface
when (interfaceExceptionSupportModule iface == Just m) $
sayExceptionSupport False
sayModuleSource :: Generator ()
sayModuleSource = do
m <- askModule
addInclude $ includeLocal $ moduleHppPath m
mapM_ (sayExport True) $ M.elems $ moduleExports m
iface <- askInterface
when (interfaceExceptionSupportModule iface == Just m) $
sayExceptionSupport True
sayExport :: Bool -> Export -> Generator ()
sayExport sayBody export = case export of
ExportVariable v -> when sayBody $ sayExportVariable v
-- Nothing to do C++ side for an enum or bitspace.
ExportEnum _ -> return ()
ExportBitspace _ -> return ()
ExportFn fn ->
-- Export a single function.
when sayBody $ do
addReqsM $ fnReqs fn
sayExportFn (fnExtName fn)
(case fnCName fn of
FnName identifier -> CallFn $ sayIdentifier identifier
FnOp op -> CallOp op)
Nothing
(fnParams fn)
(fnReturn fn)
(fnExceptionHandlers fn)
sayBody
ExportClass cls -> when sayBody $ do
let clsPtr = ptrT $ objT cls
justClsPtr = Just clsPtr
-- TODO Is this redundant for a completely empty class? (No ctors or methods, private dtor.)
addReqsM $ classReqs cls -- This is needed at least for the delete function.
-- Export each of the class's constructors.
forM_ (classCtors cls) $ \ctor ->
sayExportFn (classEntityExtName cls ctor)
(CallFn $ say "new" >> sayIdentifier (classIdentifier cls))
Nothing
(ctorParams ctor)
clsPtr
(ctorExceptionHandlers ctor)
sayBody
-- Export a delete function for the class.
when (classDtorIsPublic cls) $
sayFunction (classDeleteFnCppName cls)
["self"]
(fnT [ptrT $ constT $ objT cls] voidT) $
Just $ say "delete self;\n"
-- Export each of the class's variables.
forM_ (classVariables cls) $ sayExportClassVariable cls
-- Export each of the class's methods.
forM_ (classMethods cls) $ \method -> do
let nonMemberCall =
methodStatic method == Static ||
case methodImpl method of
RealMethod {} -> False
FnMethod {} -> True
let static = methodStatic method == Static
sayExportFn (classEntityExtName cls method)
(case methodImpl method of
RealMethod name -> case name of
FnName cName -> CallFn $ do
when static $ do
sayIdentifier (classIdentifier cls)
say "::"
say cName
FnOp op -> CallOp op
FnMethod name -> case name of
FnName cName -> CallFn $ sayIdentifier cName
FnOp op -> CallOp op)
(if nonMemberCall then Nothing else justClsPtr)
(methodParams method)
(methodReturn method)
(methodExceptionHandlers method)
sayBody
-- Export upcast functions for the class to its direct superclasses.
forM_ (classSuperclasses cls) $ genUpcastFns cls
-- Export downcast functions from the class's direct and indirect
-- superclasses to it.
unless (classIsSubclassOfMonomorphic cls) $
forM_ (classSuperclasses cls) $ genDowncastFns cls
ExportCallback cb -> do
-- Need <memory> for std::shared_ptr.
addReqsM $ callbackReqs cb `mappend` reqInclude (includeStd "memory")
sayExportCallback sayBody cb
where genUpcastFns :: Class -> Class -> Generator ()
genUpcastFns cls ancestorCls = do
sayFunction (classCastFnCppName cls ancestorCls)
["self"]
(fnT [ptrT $ constT $ objT cls] $ ptrT $ constT $ objT ancestorCls)
(Just $ say "return self;\n")
forM_ (classSuperclasses ancestorCls) $ genUpcastFns cls
genDowncastFns :: Class -> Class -> Generator ()
genDowncastFns cls ancestorCls = unless (classIsMonomorphicSuperclass ancestorCls) $ do
let clsPtr = ptrT $ constT $ objT cls
ancestorPtr = ptrT $ constT $ objT ancestorCls
sayFunction (classCastFnCppName ancestorCls cls)
["self"]
(fnT [ancestorPtr] clsPtr) $ Just $ do
say "return dynamic_cast<"
sayType Nothing clsPtr
say ">(self);\n"
forM_ (classSuperclasses ancestorCls) $ genDowncastFns cls
sayExportVariable :: Variable -> Generator ()
sayExportVariable v =
sayExportVariable' (varType v)
Nothing
True
(varGetterExtName v)
(varSetterExtName v)
(sayIdentifier $ varIdentifier v)
sayExportClassVariable :: Class -> ClassVariable -> Generator ()
sayExportClassVariable cls v =
sayExportVariable' (classVarType v)
(case classVarStatic v of
Nonstatic -> Just (ptrT $ constT $ objT cls, ptrT $ objT cls)
Static -> Nothing)
(classVarGettable v)
(classVarGetterExtName cls v)
(classVarSetterExtName cls v)
(case classVarStatic v of
Nonstatic -> say $ classVarCName v
Static -> do sayIdentifier $ classIdentifier cls
says ["::", classVarCName v])
sayExportVariable' :: Type
-> Maybe (Type, Type)
-> Bool
-> ExtName
-> ExtName
-> Generator ()
-> Generator ()
sayExportVariable' t maybeThisTypes gettable getterName setterName sayVarName = do
let (isConst, deconstType) = case t of
Internal_TConst t -> (True, t)
t -> (False, t)
-- Say a getter function.
when gettable $
sayExportFn getterName
(VarRead sayVarName)
(fmap fst maybeThisTypes)
[]
deconstType
mempty
True
-- Say a setter function.
unless isConst $
sayExportFn setterName
(VarWrite sayVarName)
(fmap snd maybeThisTypes)
[deconstType]
voidT
mempty
True
data CallType =
CallOp Operator
| CallFn (Generator ())
| VarRead (Generator ())
| VarWrite (Generator ())
sayExportFn :: ExtName
-> CallType
-> Maybe Type
-> [Type]
-> Type
-> ExceptionHandlers
-> Bool
-> Generator ()
sayExportFn extName callType maybeThisType paramTypes retType exceptionHandlers sayBody = do
handlerList <- exceptionHandlersList <$> getEffectiveExceptionHandlers exceptionHandlers
let catches = not $ null handlerList
addExceptionParamNames =
if catches then (++ [exceptionIdArgName, exceptionPtrArgName]) else id
addExceptionParamTypes = if catches then (++ [ptrT intT, ptrT $ ptrT voidT]) else id
paramCount = length paramTypes
paramCTypeMaybes = map typeToCType paramTypes
paramCTypes = zipWith fromMaybe paramTypes paramCTypeMaybes
retCTypeMaybe = typeToCType retType
retCType = fromMaybe retType retCTypeMaybe
addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes)
sayFunction (externalNameToCpp extName)
(maybe id (const ("self":)) maybeThisType $
addExceptionParamNames $
zipWith3 (\t ctm -> case t of
Internal_TCallback {} -> toArgNameAlt
_ -> if isJust ctm then toArgNameAlt else toArgName)
paramTypes paramCTypeMaybes [1..paramCount])
(fnT (addExceptionParamTypes $ maybe id (:) maybeThisType paramCTypes)
retCType) $
if not sayBody
then Nothing
else Just $ do
when catches $ do
say "try {\n"
says ["*", exceptionIdArgName, " = 0;\n"]
-- Convert arguments that aren't passed in directly.
mapM_ (sayArgRead DoDecode) $ zip3 [1..] paramTypes paramCTypeMaybes
let -- Determines how to call the exported function or method.
sayCall = case callType of
CallOp op -> do
say "("
let effectiveParamCount = paramCount + if isJust maybeThisType then 1 else 0
paramNames@(p1:p2:_) = (if isJust maybeThisType then ("(*self)":) else id) $
map toArgName [1..]
assertParamCount n =
when (effectiveParamCount /= n) $ abort $ concat
["sayExportFn: Operator ", show op, " for export ", show extName,
" requires ", show n, " parameter(s), but has ", show effectiveParamCount,
"."]
case operatorType op of
UnaryPrefixOperator symbol -> assertParamCount 1 >> says [symbol, p1]
UnaryPostfixOperator symbol -> assertParamCount 1 >> says [p1, symbol]
BinaryOperator symbol -> assertParamCount 2 >> says [p1, symbol, p2]
CallOperator ->
says $ p1 : "(" : take (effectiveParamCount - 1) (drop 1 paramNames) ++ [")"]
ArrayOperator -> assertParamCount 2 >> says [p1, "[", p2, "]"]
say ")"
CallFn sayCppName -> do
when (isJust maybeThisType) $ say "self->"
sayCppName
say "("
sayArgNames paramCount
say ")"
VarRead sayVarName -> do
when (isJust maybeThisType) $ say "self->"
sayVarName
VarWrite sayVarName -> do
when (isJust maybeThisType) $ say "self->"
sayVarName
says [" = ", toArgName 1]
-- Writes the call, transforming the return value if necessary.
-- These translations should be kept in sync with typeToCType.
sayCallAndReturn retType' retCTypeMaybe' = case (retType', retCTypeMaybe') of
(Internal_TVoid, Nothing) -> sayCall >> say ";\n"
(_, Nothing) -> say "return " >> sayCall >> say ";\n"
(Internal_TBitspace b, Just _) -> do
addReqsM $ bitspaceReqs b
let convFn = bitspaceFromCppValueFn b
say "return "
forM_ convFn $ \f -> says [f, "("]
sayCall
when (isJust convFn) $ say ")"
say ";\n";
(Internal_TRef cls, Just (Internal_TPtr cls')) | cls == cls' ->
say "return &(" >> sayCall >> say ");\n"
(Internal_TObj cls,
Just (Internal_TPtr (Internal_TConst (Internal_TObj cls')))) | cls == cls' ->
sayReturnNew cls sayCall
(Internal_TObjToHeap cls, Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' ->
sayReturnNew cls sayCall
(Internal_TToGc (Internal_TObj cls),
Just (Internal_TPtr (Internal_TObj cls'))) | cls == cls' ->
sayReturnNew cls sayCall
(Internal_TToGc retType'', _) -> sayCallAndReturn retType'' retCTypeMaybe'
ts -> abort $ concat ["sayExportFn: Unexpected return types ", show ts,
"while generating binding for ", show extName, "."]
sayCallAndReturn retType retCTypeMaybe
when catches $ do
iface <- askInterface
forM_ handlerList $ \handler -> do
say "} catch ("
case handler of
CatchClass cls -> sayVar exceptionVarName Nothing $ refT $ constT $ objT cls
CatchAll -> say "..."
say ") {\n"
exceptionId <- case handler of
CatchClass cls -> case interfaceExceptionClassId iface cls of
Just exceptionId -> return exceptionId
Nothing -> abort $ concat
["sayExportFn: Trying to catch non-exception class ", show cls,
" while generating binding for ", show extName, "."]
CatchAll -> return exceptionCatchAllId
says ["*", exceptionIdArgName, " = ", show $ getExceptionId exceptionId, ";\n"]
case handler of
CatchAll -> says ["*", exceptionPtrArgName, " = 0;\n"]
CatchClass cls -> do
-- Object pointers don't convert automatically to void*.
says ["*", exceptionPtrArgName, " = reinterpret_cast<void*>(new "]
sayType Nothing $ objT cls
says ["(", exceptionVarName, "));\n"]
-- For all of the types our gateway functions actually return, "return
-- 0" is a valid statement.
when (retType /= Internal_TVoid) $ say "return 0;\n"
say "}\n"
where sayReturnNew cls sayCall =
say "return new" >> sayIdentifier (classIdentifier cls) >> say "(" >>
sayCall >> say ");\n"
-- | If @dir@ is 'DoDecode', then we are a C++ function reading an argument from
-- foreign code. If @dir@ is 'DoEncode', then we are invoking a foreign
-- callback.
sayArgRead :: CoderDirection -> (Int, Type, Maybe Type) -> Generator ()
sayArgRead dir (n, stripConst . normalizeType -> cppType, maybeCType) = case cppType of
Internal_TBitspace b -> case maybeCType of
Just cType -> do
let cppTypeId = fromMaybe (error $ concat
["sayArgRead: Expected ", show b,
" to have a C++ type, but it doesn't."]) $
bitspaceCppTypeIdentifier b
addReqsM $ bitspaceReqs b
case dir of
-- Convert from cType to cppType.
DoDecode -> do
sayIdentifier cppTypeId
says [" ", toArgName n, " = ", fromMaybe "" $ bitspaceToCppValueFn b,
"(", toArgNameAlt n, ");\n"]
-- Convert from cppType to cType.
DoEncode -> do
sayVar (toArgName n) Nothing cType
says [" = ", fromMaybe "" $ bitspaceFromCppValueFn b,
"(", toArgNameAlt n, ");\n"]
Nothing ->
return ()
Internal_TCallback cb -> do
case dir of
DoDecode -> return ()
DoEncode -> abort $ concat
["sayArgRead: Encoding of callbacks is not supported. Given ",
show cb, "."]
says [callbackClassName cb, " ", toArgName n, "(", toArgNameAlt n, ");\n"]
t@(Internal_TPtr (Internal_TFn paramTypes retType)) -> do
-- Assert that all types referred to in a function pointer type are all
-- representable as C types.
let check label t' = (label ++ " " ++ show t') <$ typeToCType t'
mismatches = catMaybes $
check "return type" retType :
map (\paramType -> check "parameter" paramType)
paramTypes
unless (null mismatches) $
abort $ concat $
"sayArgRead: Some types within a function pointer type use non-C types, " :
"but only C types may be used. The unsupported types are: " :
intersperse "; " mismatches ++ [". The whole function type is ", show t, "."]
convertDefault
Internal_TRef t -> convertObj t
Internal_TObj _ -> convertObj $ constT cppType
Internal_TObjToHeap cls -> case dir of
DoDecode -> error $ objToHeapTWrongDirectionErrorMsg (Just "sayArgRead") cls
DoEncode -> do
sayIdentifier $ classIdentifier cls
says ["* ", toArgName n, " = new "]
sayIdentifier $ classIdentifier cls
says ["(", toArgNameAlt n, ");\n"]
Internal_TToGc t' -> case dir of
DoDecode -> error $ toGcTWrongDirectionErrorMsg (Just "sayArgRead") t'
DoEncode -> do
let newCppType = case t' of
-- In the case of (TToGc (TObj _)), we copy the temporary object to
-- the heap and let the foreign language manage that value.
Internal_TObj cls -> objToHeapT cls
_ -> t'
sayArgRead dir (n, newCppType, typeToCType newCppType)
_ -> convertDefault
where -- Primitive types don't need to be encoded/decoded. But if maybeCType is a
-- Just, then we're expected to do some encoding/decoding, so something is
-- wrong.
--
-- TODO Do we need to handle TConst?
convertDefault = forM_ maybeCType $ \cType ->
abort $ concat
["sayArgRead: Don't know how to ", show dir, " between C-type ", show cType,
" and C++-type ", show cppType, "."]
convertObj cppType' = case dir of
DoDecode -> do
sayVar (toArgName n) Nothing $ refT cppType'
says [" = *", toArgNameAlt n, ";\n"]
DoEncode -> do
sayVar (toArgName n) Nothing $ ptrT cppType'
says [" = &", toArgNameAlt n, ";\n"]
sayArgNames :: Int -> Generator ()
sayArgNames count =
says $ intersperse ", " $ map toArgName [1..count]
sayExportCallback :: Bool -> Callback -> Generator ()
sayExportCallback sayBody cb = do
throws <- getEffectiveCallbackThrows cb
let className = callbackClassName cb
implClassName = callbackImplClassName cb
fnName = callbackFnName cb
paramTypes = callbackParams cb
paramCount = length paramTypes
retType = callbackReturn cb
cbType = callbackT cb
fnType = fnT paramTypes retType
-- The function pointer we receive from foreign code will work with C-types,
-- so determine what that function looks like.
let paramCTypes = zipWith fromMaybe paramTypes $ map typeToCType paramTypes
retCType = fromMaybe retType $ typeToCType retType
addReqsM . mconcat =<< mapM typeReqs (retType:paramTypes)
let fnCType = fnT ((if throws then ([ptrT intT, ptrT $ ptrT voidT] ++) else id)
paramCTypes)
retCType
fnPtrCType = ptrT fnCType
if not sayBody
then do
-- Render the class declarations into the header file.
addInclude $ includeStd "memory" -- Needed for std::shared_ptr.
says ["\nclass ", implClassName, " {\n"]
say "public:\n"
says [" explicit ", implClassName, "("] >> sayType Nothing fnPtrCType >>
say ", void(*)(void(*)()), bool);\n"
says [" ~", implClassName, "();\n"]
say " " >> sayVar "operator()" Nothing fnType >> say ";\n"
say "private:\n"
says [" ", implClassName, "(const ", implClassName, "&);\n"]
says [" ", implClassName, "& operator=(const ", implClassName, "&);\n"]
say "\n"
say " " >> sayVar "f_" Nothing (constT fnPtrCType) >> say ";\n"
say " void (*const release_)(void(*)());\n"
say " const bool releaseRelease_;\n"
say "};\n"
says ["\nclass ", className, " {\n"]
say "public:\n"
says [" explicit ", className, "(", implClassName, "* impl) : impl_(impl) {}\n"]
say " " >> sayVar "operator()" Nothing fnType >> say ";\n"
say "private:\n"
says [" std::shared_ptr<", implClassName, "> impl_;\n"]
say "};\n"
else do
-- Render the classes' methods into the source file. First render the
-- impl class's constructor.
says ["\n", implClassName, "::", implClassName, "("] >> sayVar "f" Nothing fnPtrCType >>
say ", void (*release)(void(*)()), bool releaseRelease) :\n"
say " f_(f), release_(release), releaseRelease_(releaseRelease) {}\n"
-- Then render the destructor.
says ["\n", implClassName, "::~", implClassName, "() {\n"]
say " if (release_) {\n"
say " release_(reinterpret_cast<void(*)()>(f_));\n"
say " if (releaseRelease_) {\n"
say " release_(reinterpret_cast<void(*)()>(release_));\n"
say " }\n"
say " }\n"
say "}\n"
-- Render the impl operator() method, which does argument decoding and
-- return value encoding and passes C++ values to underlying function
-- poiner.
--
-- TODO Abstract the duplicated code here and in sayExportFn.
let paramCTypeMaybes = map typeToCType paramTypes
retCTypeMaybe = typeToCType retType
sayFunction (implClassName ++ "::operator()")
(zipWith (\ctm -> if isJust ctm then toArgNameAlt else toArgName)
paramCTypeMaybes [1..paramCount])
fnType $ Just $ do
-- Convert arguments that aren't passed in directly.
mapM_ (sayArgRead DoEncode) $ zip3 [1..] paramTypes paramCTypeMaybes
when throws $ do
says ["int ", exceptionIdArgName, " = 0;\n"]
says ["void *", exceptionPtrArgName, " = 0;\n"]
-- Add an include for the exception support module to be able to call the
-- C++ rethrow function.
iface <- askInterface
currentModule <- askModule
case interfaceExceptionSupportModule iface of
Just exceptionSupportModule ->
when (exceptionSupportModule /= currentModule) $
-- TODO Should this be includeStd?
addReqsM $ reqInclude $ includeLocal $ moduleHppPath exceptionSupportModule
Nothing -> abort $ "sayExportCallback: " ++ show iface ++
" uses exceptions, so it needs an exception support " ++
"module. Please use interfaceSetExceptionSupportModule."
-- Invoke the function pointer into foreign code.
let sayCall = do
say "f_("
when throws $ do
says ["&", exceptionIdArgName, ", &", exceptionPtrArgName]
when (paramCount /= 0) $ say ", "
sayArgNames paramCount
say ")"
sayExceptionCheck = when throws $ do
says ["if (", exceptionIdArgName, " != 0) { ",
exceptionRethrowFnName, "(", exceptionIdArgName, ", ",
exceptionPtrArgName, "); }\n"]
case (retType, retCTypeMaybe) of
(Internal_TVoid, Nothing) -> do
sayCall >> say ";\n"
sayExceptionCheck
(_, Nothing) -> do
sayVar "result" Nothing retType >> say " = " >> sayCall >> say ";\n"
sayExceptionCheck
say "return result;\n"
(Internal_TBitspace b, Just _) -> do
addReqsM $ bitspaceReqs b
let convFn = bitspaceToCppValueFn b
sayVar "result" Nothing retType
say " = "
forM_ convFn $ \f -> says [f, "("]
sayCall
when (isJust convFn) $ say ")"
say ";\n";
sayExceptionCheck
say "return result;\n"
(Internal_TObj cls1, Just retCType@(Internal_TPtr (Internal_TConst (Internal_TObj cls2))))
| cls1 == cls2 -> do
sayVar "resultPtr" Nothing retCType >> say " = " >> sayCall >> say ";\n"
sayVar "result" Nothing retType >> say " = *resultPtr;\n"
say "delete resultPtr;\n"
sayExceptionCheck
say "return result;\n"
(Internal_TRef (Internal_TConst (Internal_TObj cls1)),
Just (Internal_TPtr (Internal_TConst (Internal_TObj cls2)))) | cls1 == cls2 -> do
sayVar "result" Nothing retType >> say " = *" >> sayCall >> say ";\n"
sayExceptionCheck
say "return result;\n"
(Internal_TRef (Internal_TObj cls1),
Just (Internal_TPtr (Internal_TObj cls2))) | cls1 == cls2 -> do
sayVar "result" Nothing retType >> say " = *" >> sayCall >> say ";\n"
sayExceptionCheck
say "return result;\n"
ts -> abort $ concat
["sayExportCallback: Unexpected return types ", show ts, "."]
-- Render the non-impl operator() method, which simply passes C++ values
-- along to the impl object.
sayFunction (className ++ "::operator()")
(map toArgName [1..paramCount])
fnType $ Just $ do
case retType of
Internal_TVoid -> say "(*impl_)("
_ -> say "return (*impl_)("
sayArgNames paramCount
say ");\n"
-- Render the function that creates a new callback object.
let newCallbackFnType = fnT [ fnPtrCType
, ptrT (fnT [ptrT $ fnT [] voidT] voidT)
, boolT
]
cbType
sayFunction fnName ["f", "release", "releaseRelease"] newCallbackFnType $ Just $
says ["return new ", implClassName, "(f, release, releaseRelease);\n"]
-- | Outputs interface-wide code needed to support exceptions. Currently, this
-- comprises the function for rethrowing in C++ an exception transferred from
-- a foreign language.
sayExceptionSupport :: Bool -> Generator ()
sayExceptionSupport sayBody =
sayFunction exceptionRethrowFnName
["excId", "voidPtr"]
(fnT [intT, ptrT voidT] voidT) $
if not sayBody
then Nothing
else Just $ do
iface <- askInterface
let excClasses = interfaceAllExceptionClasses iface
says ["switch (excId) {\n"]
forM_ excClasses $ \cls -> do
excId <- fmap getExceptionId $
fromMaybeM (abort $ "sayExceptionSupport: Internal error, " ++ show cls ++
"should have an exception ID, but doesn't.") $
interfaceExceptionClassId iface cls
says ["case ", show excId, ": {\n"]
sayVar "excPtr" Nothing (ptrT $ objT cls) >> say " = reinterpret_cast<" >>
sayType Nothing (ptrT $ objT cls) >> says [">(voidPtr);\n"]
sayVar "exc" Nothing (objT cls) >> say " = *excPtr;\n"
say "delete excPtr;\n"
say "throw exc;\n"
say "}\n"
say "}\n"
says ["throw \"Internal Hoppy error, ", exceptionRethrowFnName,
" got an unknown exception ID.\";\n"]
-- | Returns a 'Type' iff there is a C type distinct from the given C++ type
-- that should be used for conversion.
typeToCType :: Type -> Maybe Type
typeToCType t = case t of
-- Because we don't know (although we could...) the direction in which we're
-- converting the bitspace value, when the bitspace has a C++ type we have to
-- assume that it needs to be converted. The caller will sort out whether a
-- conversion is actually requested.
Internal_TBitspace b -> case bitspaceCppTypeIdentifier b of
Just _ -> Just $ bitspaceType b
Nothing -> Nothing
Internal_TRef t' -> Just $ ptrT t'
Internal_TObj _ -> Just $ ptrT $ constT t
Internal_TObjToHeap cls -> Just $ ptrT $ objT cls
Internal_TToGc t'@(Internal_TObj _) -> Just $ ptrT t'
Internal_TToGc t' -> typeToCType t'
Internal_TConst t' -> typeToCType t'
_ -> Nothing
typeReqs :: Type -> Generator Reqs
typeReqs t = case t of
Internal_TVoid -> return mempty
Internal_TBool -> return mempty
Internal_TChar -> return mempty
Internal_TUChar -> return mempty
Internal_TShort -> return mempty
Internal_TUShort -> return mempty
Internal_TInt -> return mempty
Internal_TUInt -> return mempty
Internal_TLong -> return mempty
Internal_TULong -> return mempty
Internal_TLLong -> return mempty
Internal_TULLong -> return mempty
Internal_TFloat -> return mempty
Internal_TDouble -> return mempty
Internal_TInt8 -> return cstdintReqs
Internal_TInt16 -> return cstdintReqs
Internal_TInt32 -> return cstdintReqs
Internal_TInt64 -> return cstdintReqs
Internal_TWord8 -> return cstdintReqs
Internal_TWord16 -> return cstdintReqs
Internal_TWord32 -> return cstdintReqs
Internal_TWord64 -> return cstdintReqs
Internal_TPtrdiff -> return cstddefReqs
Internal_TSize -> return cstddefReqs
Internal_TSSize -> return cstddefReqs
Internal_TEnum e -> return $ enumReqs e
Internal_TBitspace b -> typeReqs $ bitspaceType b
Internal_TPtr t' -> typeReqs t'
Internal_TRef t' -> typeReqs t'
Internal_TFn paramTypes retType ->
-- TODO Is the right 'ReqsType' being used recursively here?
mconcat <$> mapM typeReqs (retType:paramTypes)
Internal_TCallback cb -> do
-- TODO Should this be includeStd?
cbClassReqs <- reqInclude . includeLocal . moduleHppPath <$>
findExportModule (callbackExtName cb)
-- TODO Is the right 'ReqsType' being used recursively here?
fnTypeReqs <- typeReqs =<< callbackToTFn cb
return $ cbClassReqs `mappend` fnTypeReqs
Internal_TObj cls -> return $ classReqs cls
Internal_TObjToHeap cls -> return $ classReqs cls
Internal_TToGc t' -> typeReqs t'
Internal_TConst t' -> typeReqs t'
cstddefReqs :: Reqs
cstddefReqs = reqInclude $ includeStd "cstddef"
cstdintReqs :: Reqs
cstdintReqs = reqInclude $ includeStd "cstdint"
findExportModule :: ExtName -> Generator Module
findExportModule extName =
fromMaybeM (abort $ concat
["findExportModule: Can't find module exporting ", fromExtName extName, "."]) =<<
fmap (M.lookup extName . interfaceNamesToModules) askInterface
getEffectiveExceptionHandlers :: ExceptionHandlers -> Generator ExceptionHandlers
getEffectiveExceptionHandlers handlers = do
ifaceHandlers <- interfaceExceptionHandlers <$> askInterface
moduleHandlers <- getExceptionHandlers <$> askModule
-- Exception handlers declared lower in the hierarchy take precedence over
-- those in the hierarchy; ExceptionHandlers is a left-biased monoid.
return $ mconcat [handlers, moduleHandlers, ifaceHandlers]
getEffectiveCallbackThrows :: Callback -> Generator Bool
getEffectiveCallbackThrows cb = case callbackThrows cb of
Just b -> return b
Nothing -> moduleCallbacksThrow <$> askModule >>= \case
Just b -> return b
Nothing -> interfaceCallbacksThrow <$> askInterface
-- | Constructs the function type for a callback. A callback that throws has
-- additional parameters.
--
-- Keep this in sync with the Haskell generator's version.
callbackToTFn :: Callback -> Generator Type
callbackToTFn cb = do
throws <- mayThrow
return $ Internal_TFn ((if throws then addExcParams else id) $ callbackParams cb)
(callbackReturn cb)
where mayThrow = case callbackThrows cb of
Just t -> return t
Nothing -> moduleCallbacksThrow <$> askModule >>= \mt -> case mt of
Just t -> return t
Nothing -> interfaceCallbacksThrow <$> askInterface
addExcParams = (++ [ptrT intT, ptrT $ ptrT voidT])