{-# LANGUAGE ViewPatterns #-}
module Foreign.Hoppy.Generator.Language.Cpp (
externalNameToCpp,
classDeleteFnCppName,
classCastFnCppName,
callbackClassName,
callbackImplClassName,
callbackFnName,
toArgName,
toArgNameAlt,
exceptionIdArgName,
exceptionPtrArgName,
exceptionVarName,
exceptionRethrowFnName,
Chunk (..),
runChunkWriter,
evalChunkWriter,
execChunkWriter,
runChunkWriterT,
evalChunkWriterT,
execChunkWriterT,
say,
says,
sayIdentifier,
sayVar,
sayType,
) where
import Control.Monad (liftM)
import Control.Monad.Writer (MonadWriter, Writer, WriterT, runWriter, runWriterT, tell)
import Data.Foldable (forM_)
import Data.List (intercalate, intersperse)
import Foreign.Hoppy.Generator.Common
import Foreign.Hoppy.Generator.Spec
import Foreign.Hoppy.Generator.Types
cppNameSeparator :: String
cppNameSeparator = "__"
makeCppName :: [String] -> String
makeCppName = intercalate cppNameSeparator
externalNamePrefix :: String
externalNamePrefix = "genpop"
externalNameToCpp :: ExtName -> String
externalNameToCpp extName =
makeCppName [externalNamePrefix, fromExtName extName]
makeClassCppName :: String -> Class -> String
makeClassCppName prefix cls = makeCppName [prefix, fromExtName $ classExtName cls]
classDeleteFnPrefix :: String
classDeleteFnPrefix = "gendel"
classDeleteFnCppName :: Class -> String
classDeleteFnCppName = makeClassCppName classDeleteFnPrefix
classCastFnCppName :: Class -> Class -> String
classCastFnCppName from to =
concat [ "gencast__"
, fromExtName $ classExtName from
, "__"
, fromExtName $ classExtName to
]
callbackClassName :: Callback -> String
callbackClassName = fromExtName . callbackExtName
callbackImplClassName :: Callback -> String
callbackImplClassName = (++ "_impl") . fromExtName . callbackExtName
callbackFnName :: Callback -> String
callbackFnName = externalNameToCpp . callbackExtName
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'] ++ "_"
newtype Chunk = Chunk { chunkContents :: String }
runChunkWriter :: Writer [Chunk] a -> (a, String)
runChunkWriter = fmap combineChunks . runWriter
evalChunkWriter :: Writer [Chunk] a -> a
evalChunkWriter = fst . runChunkWriter
execChunkWriter :: Writer [Chunk] a -> String
execChunkWriter = snd . runChunkWriter
runChunkWriterT :: Monad m => WriterT [Chunk] m a -> m (a, String)
runChunkWriterT = liftM (fmap combineChunks) . runWriterT
evalChunkWriterT :: Monad m => WriterT [Chunk] m a -> m a
evalChunkWriterT = liftM fst . runChunkWriterT
execChunkWriterT :: Monad m => WriterT [Chunk] m a -> m String
execChunkWriterT = liftM snd . runChunkWriterT
combineChunks :: [Chunk] -> String
combineChunks chunks =
let strs = map chunkContents chunks
in 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
say :: MonadWriter [Chunk] m => String -> m ()
say = tell . (:[]) . Chunk
says :: MonadWriter [Chunk] m => [String] -> m ()
says = tell . map Chunk
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 ">"
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_TBool -> say "bool" >> outer
Internal_TChar -> say "char" >> outer
Internal_TUChar -> say "unsigned char" >> outer
Internal_TShort -> say "short" >> outer
Internal_TUShort -> say "unsigned short" >> outer
Internal_TInt -> say "int" >> outer
Internal_TUInt -> say "unsigned int" >> outer
Internal_TLong -> say "long" >> outer
Internal_TULong -> say "unsigned long" >> outer
Internal_TLLong -> say "long long" >> outer
Internal_TULLong -> say "unsigned long long" >> outer
Internal_TFloat -> say "float" >> outer
Internal_TDouble -> say "double" >> outer
Internal_TInt8 -> say "int8_t" >> outer
Internal_TInt16 -> say "int16_t" >> outer
Internal_TInt32 -> say "int32_t" >> outer
Internal_TInt64 -> say "int64_t" >> outer
Internal_TWord8 -> say "uint8_t" >> outer
Internal_TWord16 -> say "uint16_t" >> outer
Internal_TWord32 -> say "uint32_t" >> outer
Internal_TWord64 -> say "uint64_t" >> outer
Internal_TPtrdiff -> say "ptrdiff_t" >> outer
Internal_TSize -> say "size_t" >> outer
Internal_TSSize -> say "ssize_t" >> outer
Internal_TEnum e -> sayIdentifier (enumIdentifier e) >> outer
Internal_TBitspace b -> case bitspaceCppTypeIdentifier b of
Just identifier -> sayIdentifier identifier >> outer
Nothing -> sayType' (bitspaceType b) maybeParamNames outerPrec unwrappedOuter
Internal_TPtr t' -> sayType' t' Nothing prec $ say "*" >> outer
Internal_TRef t' -> sayType' t' Nothing prec $ say "&" >> outer
Internal_TFn paramTypes retType -> sayType' retType Nothing prec $ do
outer
say "("
sequence_ $ intersperse (say ", ") $
for (zip paramTypes $ maybe (repeat Nothing) (map Just) maybeParamNames) $
\(ptype, pname) ->
sayType' ptype Nothing topPrecedence $ forM_ pname say
say ")"
Internal_TCallback cb -> says [callbackImplClassName cb, "*"] >> outer
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_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