{-# LANGUAGE CPP #-}
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 (when)
import Control.Monad.Writer (execWriterT, tell)
import Control.Monad.Trans (lift)
import Data.Foldable (forM_)
#if !MIN_VERSION_base(4,8,0)
import Data.Functor ((<$))
#endif
import qualified Data.Map as M
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mappend, mconcat, mempty)
#endif
import Foreign.Hoppy.Generator.Common
import Foreign.Hoppy.Generator.Language.Cpp
import Foreign.Hoppy.Generator.Spec
import Foreign.Hoppy.Generator.Types
newtype Generation = Generation
{ generatedFiles :: M.Map FilePath String
}
generate :: Interface -> Either ErrorMsg Generation
generate iface =
fmap (Generation . M.fromList) $
execWriterT $
forM_ (M.elems $ interfaceModules iface) $ \m -> do
let headerGuard = concat ["HOPPY_MODULE_", interfaceName iface, "_", moduleName m]
header <- lift $ execGenerator iface m (Just headerGuard) sayModuleHeader
tell [(moduleHppPath m, header)]
source <- lift $ execGenerator iface m Nothing sayModuleSource
tell [(moduleCppPath m, source)]
sayModuleHeader :: Generator ()
sayModuleHeader = do
m <- askModule
addReqsM $ moduleReqs m
mapM_ (sayExportCpp SayHeader) $ M.elems $ moduleExports m
iface <- askInterface
when (interfaceExceptionSupportModule iface == Just m) $
sayExceptionSupport False
sayModuleSource :: Generator ()
sayModuleSource = do
m <- askModule
addInclude $ includeLocal $ moduleHppPath m
mapM_ (sayExportCpp SaySource) $ M.elems $ moduleExports m
iface <- askInterface
when (interfaceExceptionSupportModule iface == Just m) $
sayExceptionSupport True
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"]