module Foreign.Hoppy.Generator.Language.Cpp (
externalNameToCpp,
classDeleteFnCppName,
classCastFnCppName,
callbackClassName,
callbackImplClassName,
callbackFnName,
toArgName,
toArgNameAlt,
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.Spec
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 ++ "_"
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 $ flip map (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
TVoid -> say "void" >> outer
TBool -> say "bool" >> outer
TChar -> say "char" >> outer
TUChar -> say "unsigned char" >> outer
TShort -> say "short" >> outer
TUShort -> say "unsigned short" >> outer
TInt -> say "int" >> outer
TUInt -> say "unsigned int" >> outer
TLong -> say "long" >> outer
TULong -> say "unsigned long" >> outer
TLLong -> say "long long" >> outer
TULLong -> say "unsigned long long" >> outer
TFloat -> say "float" >> outer
TDouble -> say "double" >> outer
TInt8 -> say "int8_t" >> outer
TInt16 -> say "int16_t" >> outer
TInt32 -> say "int32_t" >> outer
TInt64 -> say "int64_t" >> outer
TWord8 -> say "uint8_t" >> outer
TWord16 -> say "uint16_t" >> outer
TWord32 -> say "uint32_t" >> outer
TWord64 -> say "uint64_t" >> outer
TPtrdiff -> say "ptrdiff_t" >> outer
TSize -> say "size_t" >> outer
TSSize -> say "ssize_t" >> outer
TEnum e -> sayIdentifier (enumIdentifier e) >> outer
TBitspace b -> case bitspaceCppTypeIdentifier b of
Just identifier -> sayIdentifier identifier >> outer
Nothing -> sayType' (bitspaceType b) maybeParamNames outerPrec unwrappedOuter
TPtr t' -> sayType' t' Nothing prec $ say "*" >> outer
TRef t' -> sayType' t' Nothing prec $ say "&" >> outer
TFn paramTypes retType -> sayType' retType Nothing prec $ do
outer
say "("
sequence_ $ intersperse (say ", ") $
flip map (zip paramTypes $ maybe (repeat Nothing) (map Just) maybeParamNames) $
\(ptype, pname) ->
sayType' ptype Nothing topPrecedence $ forM_ pname say
say ")"
TCallback cb -> says [callbackImplClassName cb, "*"] >> outer
TObj cls -> sayIdentifier (classIdentifier cls) >> outer
TObjToHeap cls -> sayType' (TRef $ TConst $ TObj cls) maybeParamNames outerPrec unwrappedOuter
TConst t' -> sayType' t' maybeParamNames outerPrec $ say "const" >> unwrappedOuter
topPrecedence :: Int
topPrecedence = 11
typePrecedence :: Type -> Int
typePrecedence t = case t of
TFn {} -> 10
TPtr {} -> 9
TRef {} -> 9
_ -> 8