{-# LANGUAGE ViewPatterns #-}
module Foreign.Hoppy.Generator.Language.Cpp (
Generator,
Env,
execGenerator,
addIncludes, addInclude, addReqsM,
askInterface, askModule, abort,
makeCppName,
externalNameToCpp,
toArgName,
toArgNameAlt,
exceptionIdArgName,
exceptionPtrArgName,
exceptionVarName,
exceptionRethrowFnName,
Chunk (..),
codeChunk,
includesChunk,
runChunkWriter,
evalChunkWriter,
execChunkWriter,
runChunkWriterT,
evalChunkWriterT,
execChunkWriterT,
SayExportMode (..),
say,
says,
sayIdentifier,
renderIdentifier,
sayVar,
sayType,
sayFunction,
typeToCType,
typeReqs,
findExportModule,
getEffectiveExceptionHandlers,
) where
import Control.Monad (unless)
import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
import Control.Monad.Writer (MonadWriter, Writer, WriterT, runWriter, runWriterT, tell)
import Control.Monad.Trans (lift)
import Data.Foldable (forM_)
import Data.List (intercalate, intersperse)
import qualified Data.Map as M
import qualified Data.Set as S
import Foreign.Hoppy.Generator.Common
import Foreign.Hoppy.Generator.Spec.Base
import {-# SOURCE #-} Foreign.Hoppy.Generator.Spec.Class (classIdentifier, classReqs)
import Foreign.Hoppy.Generator.Types
type Generator = ReaderT Env (WriterT [Chunk] (Either ErrorMsg))
data Env = Env
{ envInterface :: Interface
, envModule :: Module
}
execGenerator :: Interface -> Module -> Maybe String -> Generator a -> Either ErrorMsg String
execGenerator iface m maybeHeaderGuardName action = do
chunk <- execChunkWriterT $ runReaderT action $ Env iface m
let contents = chunkContents chunk
includes = chunkIncludes chunk
return $ chunkContents $ 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"]
addIncludes :: MonadWriter [Chunk] m => [Include] -> m ()
addIncludes = tell . (:[]) . includesChunk . S.fromList
addInclude :: MonadWriter [Chunk] m => Include -> m ()
addInclude = addIncludes . (:[])
addReqsM :: MonadWriter [Chunk] m => Reqs -> m ()
addReqsM = tell . (:[]) . includesChunk . reqsIncludes
askInterface :: MonadReader Env m => m Interface
askInterface = fmap envInterface ask
askModule :: MonadReader Env m => m Module
askModule = fmap envModule ask
abort :: ErrorMsg -> Generator a
abort = lift . lift . Left
makeCppName :: [String] -> String
makeCppName = intercalate cppNameSeparator
where cppNameSeparator = "__"
externalNamePrefix :: String
externalNamePrefix = "genpop"
externalNameToCpp :: ExtName -> String
externalNameToCpp extName =
makeCppName [externalNamePrefix, fromExtName extName]
toArgName :: Int -> String
toArgName = ("arg" ++) . show
toArgNameAlt :: Int -> String
toArgNameAlt n = "arg" ++ show n ++ "_"
exceptionIdArgName :: String
exceptionIdArgName = "excId"
exceptionPtrArgName :: String
exceptionPtrArgName = "excPtr"
exceptionVarName :: String
exceptionVarName = "exc_"
exceptionRethrowFnName :: String
exceptionRethrowFnName = "genthrow"
isIdentifierChar :: Char -> Bool
isIdentifierChar = (`elem` identifierChars)
identifierChars :: String
identifierChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_"
data Chunk = Chunk
{ chunkContents :: !String
, chunkIncludes :: !(S.Set Include)
}
codeChunk :: String -> Chunk
codeChunk code =
Chunk
{ chunkContents = code
, chunkIncludes = S.empty
}
includesChunk :: S.Set Include -> Chunk
includesChunk includes =
Chunk
{ chunkContents = ""
, chunkIncludes = includes
}
runChunkWriter :: Writer [Chunk] a -> (a, Chunk)
runChunkWriter = fmap combineChunks . runWriter
evalChunkWriter :: Writer [Chunk] a -> a
evalChunkWriter = fst . runChunkWriter
execChunkWriter :: Writer [Chunk] a -> Chunk
execChunkWriter = snd . runChunkWriter
runChunkWriterT :: Monad m => WriterT [Chunk] m a -> m (a, Chunk)
runChunkWriterT = fmap (fmap combineChunks) . runWriterT
evalChunkWriterT :: Monad m => WriterT [Chunk] m a -> m a
evalChunkWriterT = fmap fst . runChunkWriterT
execChunkWriterT :: Monad m => WriterT [Chunk] m a -> m Chunk
execChunkWriterT = fmap snd . runChunkWriterT
combineChunks :: [Chunk] -> Chunk
combineChunks chunks =
let strs = map chunkContents chunks
in Chunk
{ chunkContents =
concat $ for (zip ("":strs) strs) $ \(prev, cur) ->
let needsSpace =
not (null prev) && not (null cur) &&
(let a = last prev
b = head cur
in
isIdentifierChar a && isIdentifierChar b ||
a == '>' && b == '>')
in if needsSpace then ' ':cur else cur
, chunkIncludes = S.unions $ map chunkIncludes chunks
}
data SayExportMode =
SaySource
| SayHeader
say :: MonadWriter [Chunk] m => String -> m ()
say = tell . (:[]) . codeChunk
says :: MonadWriter [Chunk] m => [String] -> m ()
says = tell . map codeChunk
sayIdentifier :: MonadWriter [Chunk] m => Identifier -> m ()
sayIdentifier =
sequence_ . intersperse (say "::") . map renderPart . identifierParts
where renderPart part = do
say $ idPartBase part
case idPartArgs part of
Nothing -> return ()
Just args -> do
say "<"
sequence_ $ intersperse (say ", ") $ map (sayType Nothing) args
say ">"
renderIdentifier :: Identifier -> String
renderIdentifier = chunkContents . execChunkWriter . sayIdentifier
sayVar :: MonadWriter [Chunk] m => String -> Maybe [String] -> Type -> m ()
sayVar name maybeParamNames t = sayType' t maybeParamNames topPrecedence $ say name
sayType :: MonadWriter [Chunk] m => Maybe [String] -> Type -> m ()
sayType maybeParamNames t = sayType' t maybeParamNames topPrecedence $ return ()
sayType' :: MonadWriter [Chunk] m => Type -> Maybe [String] -> Int -> m () -> m ()
sayType' (normalizeType -> t) maybeParamNames outerPrec unwrappedOuter =
let prec = typePrecedence t
outer = if prec <= outerPrec
then unwrappedOuter
else say "(" >> unwrappedOuter >> say ")"
in case t of
Internal_TVoid -> say "void" >> outer
Internal_TPtr t' -> sayType' t' Nothing prec $ say "*" >> outer
Internal_TRef t' -> sayType' t' Nothing prec $ say "&" >> outer
Internal_TFn params retType -> sayType' retType Nothing prec $ do
outer
say "("
sequence_ $ intersperse (say ", ") $
for (zip params $ maybe (repeat Nothing) (map Just) $ maybeParamNames) $
\(param, pname) ->
sayType' (parameterType param) Nothing topPrecedence $ forM_ pname say
say ")"
Internal_TObj cls -> sayIdentifier (classIdentifier cls) >> outer
Internal_TObjToHeap cls ->
sayType' (refT $ constT $ objT cls) maybeParamNames outerPrec unwrappedOuter
Internal_TToGc t' -> sayType' t' maybeParamNames outerPrec unwrappedOuter
Internal_TManual s -> say (conversionSpecCppName $ conversionSpecCpp s) >> outer
Internal_TConst t' -> sayType' t' maybeParamNames outerPrec $ say "const" >> unwrappedOuter
topPrecedence :: Int
topPrecedence = 11
typePrecedence :: Type -> Int
typePrecedence t = case t of
Internal_TFn {} -> 10
Internal_TPtr {} -> 9
Internal_TRef {} -> 9
_ -> 8
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"
sayVar name (Just paramNames) t
case maybeBody of
Nothing -> say ";\n"
Just body -> do
say " {\n"
body
say "}\n"
typeToCType :: Type -> Generator (Maybe Type)
typeToCType t = case t of
Internal_TRef t' -> return $ Just $ ptrT t'
Internal_TObj _ -> return $ Just $ ptrT $ constT t
Internal_TObjToHeap cls -> return $ Just $ ptrT $ objT cls
Internal_TToGc t'@(Internal_TObj _) -> return $ Just $ ptrT t'
Internal_TToGc t' -> typeToCType t'
Internal_TConst t' -> typeToCType t'
Internal_TManual s -> conversionSpecCppConversionType $ conversionSpecCpp s
_ -> return Nothing
typeReqs :: Type -> Generator Reqs
typeReqs t = case t of
Internal_TVoid -> return mempty
Internal_TPtr t' -> typeReqs t'
Internal_TRef t' -> typeReqs t'
Internal_TFn params retType ->
mconcat <$> mapM typeReqs (retType : map parameterType params)
Internal_TObj cls -> return $ classReqs cls
Internal_TObjToHeap cls -> return $ classReqs cls
Internal_TToGc t' -> typeReqs t'
Internal_TConst t' -> typeReqs t'
Internal_TManual s -> conversionSpecCppReqs $ conversionSpecCpp s
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
return $ mconcat [handlers, moduleHandlers, ifaceHandlers]