More robustness against NULL pointers

More robustness against NULL pointers

{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, OverloadedStrings, CPP #-}
module LLVM.Internal.Interop where

import Control.Applicative
import Control.Monad ( when )
import Control.Monad.Trans ( MonadIO, liftIO )
import Data.Array.Storable ( getElems )
#if __GLASGOW_HASKELL__ >= 704
import Data.Array.Unsafe ( unsafeForeignPtrToStorableArray )
#else
import Data.Array.Storable ( unsafeForeignPtrToStorableArray )
#endif
import qualified Data.ByteString.Char8 as BS
import Data.Int
import Data.Text ( Text )
import Data.Text.Encoding ( decodeUtf8 )
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable

import Data.LLVM.Types

#include "c++/marshal.h"

{#enum TypeTag {} deriving (Show, Eq) #}
{#enum ValueTag {underscoreToCase} deriving (Show, Eq) #}
{#enum MetaTag {underscoreToCase} deriving (Show, Eq) #}

data CModule
{#pointer *CModule as ModulePtr -> CModule #}

makeText :: CString -> IO Text
makeText p = do
  s <- BS.packCString p
  return (decodeUtf8 s)

cModuleIdentifier :: ModulePtr -> IO Text
cModuleIdentifier m = ({#get CModule->moduleIdentifier#} m) >>= makeText

cModuleDataLayout :: ModulePtr -> IO Text
cModuleDataLayout m = ({#get CModule->moduleDataLayout#} m) >>= makeText

cModuleTargetTriple :: ModulePtr -> IO Text
cModuleTargetTriple m = ({#get CModule->targetTriple#} m) >>= makeText

cModuleInlineAsm :: ModulePtr -> IO Text
cModuleInlineAsm m = ({#get CModule->moduleInlineAsm#} m) >>= makeText

cModuleHasError :: ModulePtr -> IO Bool
cModuleHasError m = toBool <$> ({#get CModule->hasError#} m)

cModuleErrorMessage :: ModulePtr -> IO (Maybe String)
cModuleErrorMessage m = do
  hasError <- cModuleHasError m
  case hasError of
    True -> do
      msgPtr <- ({#get CModule->errMsg#} m)
      s <- peekCString msgPtr
      return (Just s)
    False -> return Nothing

cModuleLittleEndian :: ModulePtr -> IO Bool
cModuleLittleEndian m = toBool <$> ({#get CModule->littleEndian#} m)

cModulePointerSize :: ModulePtr -> IO Int
cModulePointerSize m = fromIntegral <$> ({#get CModule->pointerSize#} m)

cModuleGlobalVariables :: ModulePtr -> IO [ValuePtr]
cModuleGlobalVariables m =
  peekArray m {#get CModule->globalVariables#} {#get CModule->numGlobalVariables#}

cModuleGlobalAliases :: ModulePtr -> IO [ValuePtr]
cModuleGlobalAliases m =
  peekArray m ({#get CModule->globalAliases#}) ({#get CModule->numGlobalAliases#})

cModuleFunctions :: ModulePtr -> IO [ValuePtr]
cModuleFunctions m =
  peekArray m ({#get CModule->functions#}) ({#get CModule->numFunctions#})

cModuleEnumMetadata :: ModulePtr -> IO [MetaPtr]
cModuleEnumMetadata m =
  peekArray m {#get CModule->enumMetadata#} {#get CModule->numEnumMetadata#}

cModuleRetainedTypeMetadata :: ModulePtr -> IO [MetaPtr]
cModuleRetainedTypeMetadata m =
  peekArray m {#get CModule->retainedTypeMetadata#} {#get CModule->numRetainedTypes#}

cModuleTypes :: ModulePtr -> IO [TypePtr]
cModuleTypes m =
  peekArray m {#get CModule->types#} {#get CModule->numTypes#}

peekArray :: forall a b c e . (Integral c, Storable e) =>
             a -> (a -> IO (Ptr b)) -> (a -> IO c) -> IO [e]
peekArray obj arrAccessor sizeAccessor = do
  nElts <- sizeAccessor obj
  arrPtr <- arrAccessor obj
  case nElts == 0 || arrPtr == nullPtr of
    True -> return []
    False -> do
      fArrPtr <- newForeignPtr_ (castPtr arrPtr)
      let elementCount :: Int
          elementCount = fromIntegral nElts
      arr <- unsafeForeignPtrToStorableArray fArrPtr (1, elementCount)
      getElems arr

data CType
{#pointer *CType as TypePtr -> CType #}
cTypeTag :: TypePtr -> IO TypeTag
cTypeTag t = toEnum . fromIntegral <$> {#get CType->typeTag#} t
cTypeSize :: TypePtr -> IO Int
cTypeSize t = fromIntegral <$> {#get CType->size#} t
cTypeIsVarArg :: TypePtr -> IO Bool
cTypeIsVarArg t = toBool <$> {#get CType->isVarArg#} t
cTypeIsPacked :: TypePtr -> IO Bool
cTypeIsPacked t = toBool <$> {#get CType->isPacked#} t
cTypeList :: TypePtr -> IO [TypePtr]
cTypeList t =
  peekArray t {#get CType->typeList#} {#get CType->typeListLen#}
cTypeInner :: TypePtr -> IO TypePtr
cTypeInner = {#get CType->innerType#}
cTypeName :: TypePtr -> IO (Maybe String)
cTypeName t = do
  n <- optionalField {#get CType->name#} t
  case n of
    Nothing -> return Nothing
    Just n' -> do
      s <- peekCString n'
      return (Just s)
cTypeAddrSpace :: TypePtr -> IO Int
cTypeAddrSpace t = fromIntegral <$> {#get CType->addrSpace#} t

cTypeSizeInBytes :: TypePtr -> IO Int
cTypeSizeInBytes t = fromIntegral <$> {#get CType->sizeInBytes#} t

data CValue
{#pointer *CValue as ValuePtr -> CValue #}
data CMeta
{#pointer *CMeta as MetaPtr -> CMeta #}

cValueTag :: ValuePtr -> IO ValueTag
cValueTag v = toEnum . fromIntegral <$> ({#get CValue->valueTag#} v)
cValueType :: ValuePtr -> IO TypePtr
cValueType = {#get CValue->valueType#}
cValueName :: (InternString m) => ValuePtr -> m (Maybe Identifier)
cValueName v = do
  tag <- liftIO $ cValueTag v
  namePtr <- liftIO $ ({#get CValue->name#}) v
  case namePtr == nullPtr of
    True -> return Nothing
    False -> do
      rawName <- liftIO $ makeText namePtr
      name <- internString rawName
      rawIdent <- case tag of
        ValFunction -> return $! makeGlobalIdentifier name
        ValGlobalvariable -> return $! makeGlobalIdentifier name
        ValAlias -> return $!  makeGlobalIdentifier name
        _ -> return $! makeLocalIdentifier name
      ident <- internIdentifier rawIdent
      return $! (Just ident)
cValueMetadata :: ValuePtr -> IO [MetaPtr]
cValueMetadata v = peekArray v {#get CValue->md#} {#get CValue->numMetadata#}
cValueSrcLoc :: ValuePtr -> IO MetaPtr
cValueSrcLoc = {#get CValue->srcLoc#}
cValueData :: ValuePtr -> IO (Ptr ())
cValueData = {#get CValue->data#}

cMetaTypeTag :: MetaPtr -> IO MetaTag
cMetaTypeTag v = toEnum . fromIntegral <$> {#get CMeta->metaTag #} v

cMetaTag :: MetaPtr -> IO DW_TAG
cMetaTag p = do
  t <- {#get CMeta->tag#} p
  case dw_tag t of
    Nothing -> return DW_TAG_unspecified_type
    Just t' -> return t'

cMetaArrayElts :: MetaPtr -> IO [Maybe MetaPtr]
cMetaArrayElts p = map convertNull <$>
  peekArray p {#get CMeta->u.metaArrayInfo.arrayElts#} {#get CMeta->u.metaArrayInfo.arrayLen#}
  where
    convertNull ptr =
      case ptr == nullPtr of
        True -> Nothing
        False -> Just ptr

cMetaEnumeratorName :: InternString m => MetaPtr -> m Text
cMetaEnumeratorName = shareString {#get CMeta->u.metaEnumeratorInfo.enumName#}
cMetaEnumeratorValue :: MetaPtr -> IO Int64
cMetaEnumeratorValue p = fromIntegral <$> {#get CMeta->u.metaEnumeratorInfo.enumValue#} p
cMetaGlobalContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaGlobalContext = optionalField {#get CMeta->u.metaGlobalInfo.context #}
cMetaGlobalName :: InternString m => MetaPtr -> m Text
cMetaGlobalName = shareString {#get CMeta->u.metaGlobalInfo.name#}
cMetaGlobalDisplayName :: InternString m => MetaPtr -> m Text
cMetaGlobalDisplayName = shareString {#get CMeta->u.metaGlobalInfo.displayName#}
cMetaGlobalLinkageName :: InternString m => MetaPtr -> m Text
cMetaGlobalLinkageName = shareString {#get CMeta->u.metaGlobalInfo.linkageName#}
-- cMetaGlobalCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaGlobalCompileUnit = {#get CMeta->u.metaGlobalInfo.compileUnit#}
cMetaGlobalLine :: MetaPtr -> IO Int32
cMetaGlobalLine p = fromIntegral <$> {#get CMeta->u.metaGlobalInfo.lineNumber#} p
cMetaGlobalType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaGlobalType = optionalField {#get CMeta->u.metaGlobalInfo.globalType#}
cMetaGlobalIsLocal :: MetaPtr -> IO Bool
cMetaGlobalIsLocal p = toBool <$> {#get CMeta->u.metaGlobalInfo.isLocalToUnit#} p
cMetaGlobalIsDefinition :: MetaPtr -> IO Bool
cMetaGlobalIsDefinition p = toBool <$> {#get CMeta->u.metaGlobalInfo.isDefinition#} p
cMetaLocationLine :: MetaPtr -> IO Int32
cMetaLocationLine p = fromIntegral <$> {#get CMeta->u.metaLocationInfo.lineNumber#} p
cMetaLocationColumn :: MetaPtr -> IO Int32
cMetaLocationColumn p = fromIntegral <$> {#get CMeta->u.metaLocationInfo.columnNumber#} p
cMetaLocationScope :: MetaPtr -> IO (Maybe MetaPtr)
cMetaLocationScope = optionalField {#get CMeta->u.metaLocationInfo.scope#}
cMetaSubrangeLo :: MetaPtr -> IO Int64
cMetaSubrangeLo p = fromIntegral <$> {#get CMeta->u.metaSubrangeInfo.lo#} p
cMetaSubrangeHi :: MetaPtr -> IO Int64
cMetaSubrangeHi p = fromIntegral <$> {#get CMeta->u.metaSubrangeInfo.hi#} p
cMetaTemplateTypeContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateTypeContext = optionalField {#get CMeta->u.metaTemplateTypeInfo.context#}
cMetaTemplateTypeName :: InternString m => MetaPtr -> m Text
cMetaTemplateTypeName = shareString {#get CMeta->u.metaTemplateTypeInfo.name#}
cMetaTemplateTypeType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateTypeType = optionalField {#get CMeta->u.metaTemplateTypeInfo.type#}
cMetaTemplateTypeLine :: MetaPtr -> IO Int32
cMetaTemplateTypeLine p = fromIntegral <$> {#get CMeta->u.metaTemplateTypeInfo.lineNumber#} p
cMetaTemplateTypeColumn :: MetaPtr -> IO Int32
cMetaTemplateTypeColumn p = fromIntegral <$> {#get CMeta->u.metaTemplateTypeInfo.columnNumber#} p
cMetaTemplateValueContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateValueContext = optionalField {#get CMeta->u.metaTemplateValueInfo.context#}
cMetaTemplateValueName :: InternString m => MetaPtr -> m Text
cMetaTemplateValueName = shareString {#get CMeta->u.metaTemplateValueInfo.name#}
cMetaTemplateValueType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateValueType = optionalField {#get CMeta->u.metaTemplateValueInfo.type#}
cMetaTemplateValueValue :: MetaPtr -> IO Int64
cMetaTemplateValueValue p = fromIntegral <$> {#get CMeta->u.metaTemplateValueInfo.value#} p
cMetaTemplateValueLine :: MetaPtr -> IO Int32
cMetaTemplateValueLine p = fromIntegral <$> {#get CMeta->u.metaTemplateValueInfo.lineNumber#} p
cMetaTemplateValueColumn :: MetaPtr -> IO Int32
cMetaTemplateValueColumn p = fromIntegral <$> {#get CMeta->u.metaTemplateValueInfo.columnNumber#} p
cMetaVariableContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaVariableContext = optionalField {#get CMeta->u.metaVariableInfo.context#}
cMetaVariableName :: InternString m => MetaPtr -> m Text
cMetaVariableName = shareString {#get CMeta->u.metaVariableInfo.name#}
-- cMetaVariableCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaVariableCompileUnit = {#get CMeta->u.metaVariableInfo.compileUnit#}
cMetaVariableLine :: MetaPtr -> IO Int32
cMetaVariableLine p = fromIntegral <$> {#get CMeta->u.metaVariableInfo.lineNumber#} p
cMetaVariableArgNumber :: MetaPtr -> IO Int32
cMetaVariableArgNumber p = fromIntegral <$> {#get CMeta->u.metaVariableInfo.argNumber#} p
cMetaVariableType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaVariableType = optionalField {#get CMeta->u.metaVariableInfo.type#}
cMetaVariableIsArtificial :: MetaPtr -> IO Bool
cMetaVariableIsArtificial p = toBool <$> {#get CMeta->u.metaVariableInfo.isArtificial#} p
cMetaVariableHasComplexAddress :: MetaPtr -> IO Bool
cMetaVariableHasComplexAddress p = toBool <$> {#get CMeta->u.metaVariableInfo.hasComplexAddress #} p
cMetaVariableAddrElements :: MetaPtr -> IO [Int64]
cMetaVariableAddrElements p = do
  ca <- cMetaVariableHasComplexAddress p
  case ca of
    True -> peekArray p {#get CMeta->u.metaVariableInfo.addrElements#} {#get CMeta->u.metaVariableInfo.numAddrElements#}
    False -> return []
cMetaVariableIsBlockByRefVar :: MetaPtr -> IO Bool
cMetaVariableIsBlockByRefVar p = toBool <$> {#get CMeta->u.metaVariableInfo.isBlockByRefVar#} p
cMetaCompileUnitLanguage :: MetaPtr -> IO DW_LANG
cMetaCompileUnitLanguage p = dw_lang <$> {#get CMeta->u.metaCompileUnitInfo.language#} p
cMetaCompileUnitFilename :: InternString m => MetaPtr -> m Text
cMetaCompileUnitFilename = shareString {#get CMeta->u.metaCompileUnitInfo.filename#}
cMetaCompileUnitDirectory :: InternString m => MetaPtr -> m Text
cMetaCompileUnitDirectory = shareString {#get CMeta->u.metaCompileUnitInfo.directory#}
cMetaCompileUnitProducer :: InternString m => MetaPtr -> m Text
cMetaCompileUnitProducer = shareString {#get CMeta->u.metaCompileUnitInfo.producer#}
cMetaCompileUnitIsMain :: MetaPtr -> IO Bool
cMetaCompileUnitIsMain p = toBool <$> {#get CMeta->u.metaCompileUnitInfo.isMain#} p
cMetaCompileUnitIsOptimized :: MetaPtr -> IO Bool
cMetaCompileUnitIsOptimized p = toBool <$> {#get CMeta->u.metaCompileUnitInfo.isOptimized#} p
cMetaCompileUnitFlags :: InternString m => MetaPtr -> m Text
cMetaCompileUnitFlags = shareString {#get CMeta->u.metaCompileUnitInfo.flags#}
cMetaCompileUnitRuntimeVersion :: MetaPtr -> IO Int32
cMetaCompileUnitRuntimeVersion p = fromIntegral <$> {#get CMeta->u.metaCompileUnitInfo.runtimeVersion#} p
cMetaCompileUnitEnumTypes :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitEnumTypes = optionalField {#get CMeta->u.metaCompileUnitInfo.enumTypes#}
cMetaCompileUnitRetainedTypes :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitRetainedTypes = optionalField {#get CMeta->u.metaCompileUnitInfo.retainedTypes#}
cMetaCompileUnitSubprograms :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitSubprograms = optionalField {#get CMeta->u.metaCompileUnitInfo.subprograms#}
cMetaCompileUnitGlobalVariables :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitGlobalVariables = optionalField {#get CMeta->u.metaCompileUnitInfo.globalVariables#}
cMetaFileFilename :: InternString m => MetaPtr -> m Text
cMetaFileFilename = shareString {#get CMeta->u.metaFileInfo.filename#}
cMetaFileDirectory :: InternString m => MetaPtr -> m Text
cMetaFileDirectory = shareString {#get CMeta->u.metaFileInfo.directory#}
-- cMetaFileCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaFileCompileUnit = {#get CMeta->u.metaFileInfo.compileUnit#}
cMetaLexicalBlockContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaLexicalBlockContext = optionalField {#get CMeta->u.metaLexicalBlockInfo.context#}
cMetaLexicalBlockLine :: MetaPtr -> IO Int32
cMetaLexicalBlockLine p = fromIntegral <$> {#get CMeta->u.metaLexicalBlockInfo.lineNumber#} p
cMetaLexicalBlockColumn :: MetaPtr -> IO Int32
cMetaLexicalBlockColumn p = fromIntegral <$> {#get CMeta->u.metaLexicalBlockInfo.columnNumber#} p
cMetaNamespaceContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaNamespaceContext = optionalField {#get CMeta->u.metaNamespaceInfo.context#}
cMetaNamespaceName :: InternString m => MetaPtr -> m Text
cMetaNamespaceName = shareString {#get CMeta->u.metaNamespaceInfo.name#}
-- cMetaNamespaceCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaNamespaceCompileUnit = {#get CMeta->u.metaNamespaceInfo.compileUnit#}
cMetaNamespaceLine :: MetaPtr -> IO Int32
cMetaNamespaceLine p = fromIntegral <$> {#get CMeta->u.metaNamespaceInfo.lineNumber#} p
cMetaSubprogramContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaSubprogramContext = optionalField {#get CMeta->u.metaSubprogramInfo.context#}
cMetaSubprogramName :: InternString m => MetaPtr -> m Text
cMetaSubprogramName = shareString {#get CMeta->u.metaSubprogramInfo.name#}
cMetaSubprogramDisplayName :: InternString m => MetaPtr -> m Text
cMetaSubprogramDisplayName = shareString {#get CMeta->u.metaSubprogramInfo.displayName#}
cMetaSubprogramLinkageName :: InternString m => MetaPtr -> m Text
cMetaSubprogramLinkageName = shareString {#get CMeta->u.metaSubprogramInfo.linkageName#}
-- cMetaSubprogramCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaSubprogramCompileUnit = {#get CMeta->u.metaSubprogramInfo.compileUnit#}
cMetaSubprogramLine :: MetaPtr -> IO Int32
cMetaSubprogramLine p = fromIntegral <$> {#get CMeta->u.metaSubprogramInfo.lineNumber#} p
cMetaSubprogramType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaSubprogramType = optionalField {#get CMeta->u.metaSubprogramInfo.type#}
cMetaSubprogramIsLocal :: MetaPtr -> IO Bool
cMetaSubprogramIsLocal p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isLocalToUnit#} p
cMetaSubprogramIsDefinition :: MetaPtr -> IO Bool
cMetaSubprogramIsDefinition p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isDefinition#} p
cMetaSubprogramVirtuality :: MetaPtr -> IO DW_VIRTUALITY
cMetaSubprogramVirtuality p = dw_virtuality <$> {#get CMeta->u.metaSubprogramInfo.virtuality#} p
cMetaSubprogramVirtualIndex :: MetaPtr -> IO Int32
cMetaSubprogramVirtualIndex p = fromIntegral <$> {#get CMeta->u.metaSubprogramInfo.virtualIndex#} p
cMetaSubprogramContainingType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaSubprogramContainingType = optionalField {#get CMeta->u.metaSubprogramInfo.containingType#}
cMetaSubprogramIsArtificial :: MetaPtr -> IO Bool
cMetaSubprogramIsArtificial p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isArtificial#} p
cMetaSubprogramIsPrivate :: MetaPtr -> IO Bool
cMetaSubprogramIsPrivate p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isPrivate#} p
cMetaSubprogramIsProtected :: MetaPtr -> IO Bool
cMetaSubprogramIsProtected p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isProtected#} p
cMetaSubprogramIsExplicit :: MetaPtr -> IO Bool
cMetaSubprogramIsExplicit p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isExplicit#} p
cMetaSubprogramIsPrototyped :: MetaPtr -> IO Bool
cMetaSubprogramIsPrototyped p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isPrototyped#} p
cMetaSubprogramIsOptimized :: MetaPtr -> IO Bool
cMetaSubprogramIsOptimized p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isOptimized#} p
cMetaTypeContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeContext = optionalField {#get CMeta->u.metaTypeInfo.context#}
cMetaTypeName :: InternString m => MetaPtr -> m Text
cMetaTypeName = shareString {#get CMeta->u.metaTypeInfo.name#}
-- cMetaTypeCompileUnit :: MetaPtr -> IO (Maybe MetaPtr)
-- cMetaTypeCompileUnit = optionalField {#get CMeta->u.metaTypeInfo.compileUnit#}
-- cMetaTypeFile :: MetaPtr -> IO (Maybe MetaPtr)
-- cMetaTypeFile = optionalField {#get CMeta->u.metaTypeInfo.file#}
cMetaTypeLine :: MetaPtr -> IO Int32
cMetaTypeLine p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.lineNumber#} p
cMetaTypeSize :: MetaPtr -> IO Int64
cMetaTypeSize p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.sizeInBits#} p
cMetaTypeAlign :: MetaPtr -> IO Int64
cMetaTypeAlign p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.alignInBits#} p
cMetaTypeOffset :: MetaPtr -> IO Int64
cMetaTypeOffset p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.offsetInBits#} p
cMetaTypeFlags :: MetaPtr -> IO Int32
cMetaTypeFlags p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.flags#} p
cMetaTypeIsPrivate :: MetaPtr -> IO Bool
cMetaTypeIsPrivate p = toBool <$> {#get CMeta->u.metaTypeInfo.isPrivate#} p
cMetaTypeIsProtected :: MetaPtr -> IO Bool
cMetaTypeIsProtected p = toBool <$> {#get CMeta->u.metaTypeInfo.isProtected#} p
cMetaTypeIsForward :: MetaPtr -> IO Bool
cMetaTypeIsForward p = toBool <$> {#get CMeta->u.metaTypeInfo.isForward#} p
cMetaTypeIsByRefStruct :: MetaPtr -> IO Bool
cMetaTypeIsByRefStruct p = toBool <$> {#get CMeta->u.metaTypeInfo.isByRefStruct#} p
cMetaTypeIsVirtual :: MetaPtr -> IO Bool
cMetaTypeIsVirtual p = toBool <$> {#get CMeta->u.metaTypeInfo.isVirtual#} p
cMetaTypeIsArtificial :: MetaPtr -> IO Bool
cMetaTypeIsArtificial p = toBool <$> {#get CMeta->u.metaTypeInfo.isArtificial#} p
cMetaTypeDirectory :: InternString m => MetaPtr -> m Text
cMetaTypeDirectory = shareString {#get CMeta->u.metaTypeInfo.directory#}
cMetaTypeFilename :: InternString m => MetaPtr -> m Text
cMetaTypeFilename = shareString {#get CMeta->u.metaTypeInfo.filename#}
cMetaTypeEncoding :: MetaPtr -> IO DW_ATE
cMetaTypeEncoding p = dw_ate <$> {#get CMeta->u.metaTypeInfo.encoding#} p
cMetaTypeDerivedFrom :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeDerivedFrom = optionalField {#get CMeta->u.metaTypeInfo.typeDerivedFrom#}
cMetaTypeCompositeComponents :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeCompositeComponents = optionalField {#get CMeta->u.metaTypeInfo.typeArray#}
cMetaTypeRuntimeLanguage :: MetaPtr -> IO Int32
cMetaTypeRuntimeLanguage p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.runTimeLang#} p
cMetaTypeContainingType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeContainingType = optionalField {#get CMeta->u.metaTypeInfo.containingType#}
cMetaTypeTemplateParams :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeTemplateParams = optionalField {#get CMeta->u.metaTypeInfo.templateParams#}
cMetaUnknownRepr :: InternString m => MetaPtr -> m Text
cMetaUnknownRepr = shareString {#get CMeta->u.metaUnknownInfo.repr#}

optionalField :: (a -> IO (Ptr b)) -> a -> IO (Maybe (Ptr b))
optionalField accessor p = do
  v <- accessor p
  case v == nullPtr of
    True -> return Nothing
    False -> return (Just v)

class MonadIO m => InternString m where
  internString :: Text -> m Text
  internIdentifier :: Identifier -> m Identifier

-- | This helper converts C char* strings into Texts, sharing
-- identical bytestrings on the Haskell side.  This is a simple
-- space-saving optimization (assuming the entire cache is garbage
-- collected)
shareString :: InternString m => (a -> IO CString) -> a -> m Text
shareString accessor ptr = do
  sp <- liftIO $ accessor ptr
  str <- case sp == nullPtr of
    False -> liftIO $ BS.packCString sp
    True -> return $ BS.pack ""
  internString (decodeUtf8 str)

data CGlobalInfo
{#pointer *CGlobalInfo as GlobalInfoPtr -> CGlobalInfo #}
cGlobalIsExternal :: GlobalInfoPtr -> IO Bool
cGlobalIsExternal g = toBool <$> ({#get CGlobalInfo->isExternal#} g)
cGlobalAlignment :: GlobalInfoPtr -> IO Int64
cGlobalAlignment g = fromIntegral <$> ({#get CGlobalInfo->alignment#} g)
cGlobalVisibility :: GlobalInfoPtr -> IO VisibilityStyle
cGlobalVisibility g = toEnum . fromIntegral <$> ({#get CGlobalInfo->visibility#} g)
cGlobalLinkage :: GlobalInfoPtr -> IO LinkageType
cGlobalLinkage g = toEnum . fromIntegral <$> ({#get CGlobalInfo->linkage#} g)
cGlobalSection :: GlobalInfoPtr -> IO (Maybe Text)
cGlobalSection g = do
  s <- {#get CGlobalInfo->section#} g
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just (decodeUtf8 bs)
cGlobalInitializer :: GlobalInfoPtr -> IO ValuePtr
cGlobalInitializer = {#get CGlobalInfo->initializer#}
cGlobalIsThreadLocal :: GlobalInfoPtr -> IO Bool
cGlobalIsThreadLocal g = toBool <$> ({#get CGlobalInfo->isThreadLocal#} g)
cGlobalAliasee :: GlobalInfoPtr -> IO ValuePtr
cGlobalAliasee = {#get CGlobalInfo->aliasee#}
cGlobalIsConstant :: GlobalInfoPtr -> IO Bool
cGlobalIsConstant g = toBool <$> {#get CGlobalInfo->isConstant#} g

data CFunctionInfo
{#pointer *CFunctionInfo as FunctionInfoPtr -> CFunctionInfo #}
cFunctionIsExternal :: FunctionInfoPtr -> IO Bool
cFunctionIsExternal f = toBool <$> {#get CFunctionInfo->isExternal#} f
cFunctionAlignment :: FunctionInfoPtr -> IO Int64
cFunctionAlignment f = fromIntegral <$> {#get CFunctionInfo->alignment#} f
cFunctionVisibility :: FunctionInfoPtr -> IO VisibilityStyle
cFunctionVisibility f = toEnum . fromIntegral <$> {#get CFunctionInfo->visibility#} f
cFunctionLinkage :: FunctionInfoPtr -> IO LinkageType
cFunctionLinkage f = toEnum . fromIntegral <$> {#get CFunctionInfo->linkage#} f
cFunctionSection :: FunctionInfoPtr -> IO (Maybe Text)
cFunctionSection f = do
  s <- {#get CFunctionInfo->section#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just (decodeUtf8 bs)
cFunctionIsVarArg :: FunctionInfoPtr -> IO Bool
cFunctionIsVarArg f = toBool <$> {#get CFunctionInfo->isVarArg#} f
cFunctionCallingConvention :: FunctionInfoPtr -> IO CallingConvention
cFunctionCallingConvention f = toEnum . fromIntegral <$> {#get CFunctionInfo->callingConvention#} f
cFunctionGCName :: FunctionInfoPtr -> IO (Maybe Text)
cFunctionGCName f = do
  s <- {#get CFunctionInfo->gcName#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just (decodeUtf8 bs)
cFunctionArguments :: FunctionInfoPtr -> IO [ValuePtr]
cFunctionArguments f =
  peekArray f {#get CFunctionInfo->arguments#} {#get CFunctionInfo->argListLen#}
cFunctionBlocks :: FunctionInfoPtr -> IO [ValuePtr]
cFunctionBlocks f =
  peekArray f {#get CFunctionInfo->body#} {#get CFunctionInfo->blockListLen#}

data CArgInfo
{#pointer *CArgumentInfo as ArgInfoPtr -> CArgInfo #}
cArgInfoHasSRet :: ArgInfoPtr -> IO Bool
cArgInfoHasSRet a = toBool <$> ({#get CArgumentInfo->hasSRet#} a)
cArgInfoHasByVal :: ArgInfoPtr -> IO Bool
cArgInfoHasByVal a = toBool <$> ({#get CArgumentInfo->hasByVal#} a)
cArgInfoHasNest :: ArgInfoPtr -> IO Bool
cArgInfoHasNest a = toBool <$> ({#get CArgumentInfo->hasNest#} a)
cArgInfoHasNoAlias :: ArgInfoPtr -> IO Bool
cArgInfoHasNoAlias a = toBool <$> ({#get CArgumentInfo->hasNoAlias#} a)
cArgInfoHasNoCapture :: ArgInfoPtr -> IO Bool
cArgInfoHasNoCapture a = toBool <$> ({#get CArgumentInfo->hasNoCapture#} a)

data CBasicBlockInfo
{#pointer *CBasicBlockInfo as BasicBlockPtr -> CBasicBlockInfo #}

cBasicBlockInstructions :: BasicBlockPtr -> IO [ValuePtr]
cBasicBlockInstructions b =
  peekArray b {#get CBasicBlockInfo->instructions#} {#get CBasicBlockInfo->blockLen#}

data CInlineAsmInfo
{#pointer *CInlineAsmInfo as InlineAsmInfoPtr -> CInlineAsmInfo #}

cInlineAsmString :: InlineAsmInfoPtr -> IO Text
cInlineAsmString a =
  ({#get CInlineAsmInfo->asmString#} a) >>= makeText
cInlineAsmConstraints :: InlineAsmInfoPtr -> IO Text
cInlineAsmConstraints a =
  ({#get CInlineAsmInfo->constraintString#} a) >>= makeText

data CBlockAddrInfo
{#pointer *CBlockAddrInfo as BlockAddrInfoPtr -> CBlockAddrInfo #}

cBlockAddrFunc :: BlockAddrInfoPtr -> IO ValuePtr
cBlockAddrFunc = {#get CBlockAddrInfo->func #}
cBlockAddrBlock :: BlockAddrInfoPtr -> IO ValuePtr
cBlockAddrBlock = {#get CBlockAddrInfo->block #}

data CAggregateInfo
{#pointer *CConstAggregate as AggregateInfoPtr -> CAggregateInfo #}

cAggregateValues :: AggregateInfoPtr -> IO [ValuePtr]
cAggregateValues a =
  peekArray a {#get CConstAggregate->constants#} {#get CConstAggregate->numElements#}

data CConstFP
{#pointer *CConstFP as FPInfoPtr -> CConstFP #}
cFPVal :: FPInfoPtr -> IO Double
cFPVal f = realToFrac <$> ({#get CConstFP->val#} f)

data CConstInt
{#pointer *CConstInt as IntInfoPtr -> CConstInt #}
cIntVal :: IntInfoPtr -> IO Integer
cIntVal i = fromIntegral <$> ({#get CConstInt->val#} i)
cIntHugeVal :: IntInfoPtr -> IO (Maybe Integer)
cIntHugeVal i = do
  s <- {#get CConstInt->hugeVal#} i
  case s == nullPtr of
    True -> return Nothing
    False -> (Just . read) <$> peekCString s

data CInstructionInfo
{#pointer *CInstructionInfo as InstInfoPtr -> CInstructionInfo #}
cInstructionOperands :: InstInfoPtr -> IO [ValuePtr]
cInstructionOperands i =
  peekArray i {#get CInstructionInfo->operands#} {#get CInstructionInfo->numOperands#}
cInstructionArithFlags :: InstInfoPtr -> IO ArithFlags
cInstructionArithFlags o = toEnum . fromIntegral <$> {#get CInstructionInfo->flags#} o
cInstructionAlign :: InstInfoPtr -> IO Int64
cInstructionAlign u = fromIntegral <$> {#get CInstructionInfo->align#} u
cInstructionIsVolatile :: InstInfoPtr -> IO Bool
cInstructionIsVolatile u = toBool <$> {#get CInstructionInfo->isVolatile#} u
cInstructionAddrSpace :: InstInfoPtr -> IO Int
cInstructionAddrSpace u = fromIntegral <$> {#get CInstructionInfo->addrSpace#} u
cInstructionCmpPred :: InstInfoPtr -> IO CmpPredicate
cInstructionCmpPred c = toEnum . fromIntegral <$> {#get CInstructionInfo->cmpPred#} c
cInstructionInBounds :: InstInfoPtr -> IO Bool
cInstructionInBounds g = toBool <$> {#get CInstructionInfo->inBounds#} g
cInstructionIndices :: InstInfoPtr -> IO [Int]
cInstructionIndices i =
  peekArray i {#get CInstructionInfo->indices#} {#get CInstructionInfo->numIndices#}

data CConstExprInfo
{#pointer *CConstExprInfo as ConstExprPtr -> CConstExprInfo #}
cConstExprTag :: ConstExprPtr -> IO ValueTag
cConstExprTag e = toEnum . fromIntegral <$> {#get CConstExprInfo->instrType#} e
cConstExprInstInfo :: ConstExprPtr -> IO InstInfoPtr
cConstExprInstInfo = {#get CConstExprInfo->ii#}

data CPHIInfo
{#pointer *CPHIInfo as PHIInfoPtr -> CPHIInfo #}
cPHIValues :: PHIInfoPtr -> IO [ValuePtr]
cPHIValues p =
  peekArray p {#get CPHIInfo->incomingValues#} {#get CPHIInfo->numIncomingValues#}
cPHIBlocks :: PHIInfoPtr -> IO [ValuePtr]
cPHIBlocks p =
  peekArray p {#get CPHIInfo->valueBlocks#} {#get CPHIInfo->numIncomingValues#}

data CCallInfo
{#pointer *CCallInfo as CallInfoPtr -> CCallInfo #}
cCallValue :: CallInfoPtr -> IO ValuePtr
cCallValue = {#get CCallInfo->calledValue #}
cCallArguments :: CallInfoPtr -> IO [ValuePtr]
cCallArguments c =
  peekArray c {#get CCallInfo->arguments#} {#get CCallInfo->argListLen#}
cCallConvention :: CallInfoPtr -> IO CallingConvention
cCallConvention c = toEnum . fromIntegral <$> {#get CCallInfo->callingConvention#} c
cCallHasSRet :: CallInfoPtr -> IO Bool
cCallHasSRet c = toBool <$> {#get CCallInfo->hasSRet#} c
cCallIsTail :: CallInfoPtr -> IO Bool
cCallIsTail c = toBool <$> {#get CCallInfo->isTail#} c
cCallUnwindDest :: CallInfoPtr -> IO ValuePtr
cCallUnwindDest = {#get CCallInfo->unwindDest#}
cCallNormalDest :: CallInfoPtr -> IO ValuePtr
cCallNormalDest = {#get CCallInfo->normalDest#}

data CAtomicInfo
{#pointer *CAtomicInfo as AtomicInfoPtr -> CAtomicInfo #}
cAtomicOrdering :: AtomicInfoPtr -> IO AtomicOrdering
cAtomicOrdering ai = toEnum . fromIntegral <$> {#get CAtomicInfo->ordering#} ai
cAtomicScope :: AtomicInfoPtr -> IO SynchronizationScope
cAtomicScope ai = toEnum . fromIntegral <$> {#get CAtomicInfo->scope#} ai
cAtomicOperation :: AtomicInfoPtr -> IO AtomicOperation
cAtomicOperation ai = toEnum . fromIntegral <$> {#get CAtomicInfo->operation#} ai
cAtomicIsVolatile :: AtomicInfoPtr -> IO Bool
cAtomicIsVolatile ai = toBool <$> {#get CAtomicInfo->isVolatile#} ai
cAtomicAddressSpace :: AtomicInfoPtr -> IO Int
cAtomicAddressSpace ai = fromIntegral <$> {#get CAtomicInfo->addrSpace#} ai
cAtomicPointerOperand :: AtomicInfoPtr -> IO ValuePtr
cAtomicPointerOperand = {#get CAtomicInfo->pointerOperand#}
cAtomicValueOperand :: AtomicInfoPtr -> IO ValuePtr
cAtomicValueOperand = {#get CAtomicInfo->valueOperand#}
cAtomicCompareOperand :: AtomicInfoPtr -> IO ValuePtr
cAtomicCompareOperand = {#get CAtomicInfo->compareOperand#}

data CLandingPadInfo
{#pointer *CLandingPadInfo as LandingPadInfoPtr -> CLandingPadInfo#}
cLandingPadPersonality :: LandingPadInfoPtr -> IO ValuePtr
cLandingPadPersonality = {#get CLandingPadInfo->personality#}
cLandingPadIsCleanup :: LandingPadInfoPtr -> IO Bool
cLandingPadIsCleanup li = toBool <$> {#get CLandingPadInfo->isCleanup#} li
cLandingPadClauses :: LandingPadInfoPtr -> IO [ValuePtr]
cLandingPadClauses li =
  peekArray li {#get CLandingPadInfo->clauses #} {#get CLandingPadInfo->numClauses#}
cLandingPadClauseTypes :: LandingPadInfoPtr -> IO [LandingPadClause]
cLandingPadClauseTypes li = do
  arr <- peekArray li {#get CLandingPadInfo->clauseTypes #} {#get CLandingPadInfo->numClauses#}
  return $ map toEnum arr

-- | Parse the named file into an FFI-friendly representation of an
-- LLVM module.
{#fun marshalLLVM { id `Ptr CChar', `Int',  fromBool `Bool' } -> `ModulePtr' id #}
{#fun marshalLLVMFile { `String', fromBool `Bool' } -> `ModulePtr' id #}

-- | Free all of the resources allocated by 'marshalLLVM'
{#fun disposeCModule { id `ModulePtr' } -> `()' #}

-- Helpers

-- This only seems to be necessary on i386 for some reason.
cIntConv :: (Integral a, Num b) => a -> b
cIntConv = fromIntegral

{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, OverloadedStrings, CPP #-}
module LLVM.Internal.Interop where

import Control.Applicative
import Control.Monad ( when )
import Control.Monad.Trans ( MonadIO, liftIO )
import Data.Array.Storable ( getElems )
#if __GLASGOW_HASKELL__ >= 704
import Data.Array.Unsafe ( unsafeForeignPtrToStorableArray )
#else
import Data.Array.Storable ( unsafeForeignPtrToStorableArray )
#endif
import qualified Data.ByteString.Char8 as BS
import Data.Int
import Data.Text ( Text )
import Data.Text.Encoding ( decodeUtf8 )
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable

import Data.LLVM.Types

#include "c++/marshal.h"

{#enum TypeTag {} deriving (Show, Eq) #}
{#enum ValueTag {underscoreToCase} deriving (Show, Eq) #}
{#enum MetaTag {underscoreToCase} deriving (Show, Eq) #}

data CModule
{#pointer *CModule as ModulePtr -> CModule #}

makeText :: CString -> IO Text
makeText p = do
  s <- BS.packCString p
  return (decodeUtf8 s)

cModuleIdentifier :: ModulePtr -> IO Text
cModuleIdentifier m = ({#get CModule->moduleIdentifier#} m) >>= makeText

cModuleDataLayout :: ModulePtr -> IO Text
cModuleDataLayout m = ({#get CModule->moduleDataLayout#} m) >>= makeText

cModuleTargetTriple :: ModulePtr -> IO Text
cModuleTargetTriple m = ({#get CModule->targetTriple#} m) >>= makeText

cModuleInlineAsm :: ModulePtr -> IO Text
cModuleInlineAsm m = ({#get CModule->moduleInlineAsm#} m) >>= makeText

cModuleHasError :: ModulePtr -> IO Bool
cModuleHasError m = toBool <$> ({#get CModule->hasError#} m)

cModuleErrorMessage :: ModulePtr -> IO (Maybe String)
cModuleErrorMessage m = do
  hasError <- cModuleHasError m
  case hasError of
    True -> do
      msgPtr <- ({#get CModule->errMsg#} m)
      s <- peekCString msgPtr
      return (Just s)
    False -> return Nothing

cModuleLittleEndian :: ModulePtr -> IO Bool
cModuleLittleEndian m = toBool <$> ({#get CModule->littleEndian#} m)

cModulePointerSize :: ModulePtr -> IO Int
cModulePointerSize m = fromIntegral <$> ({#get CModule->pointerSize#} m)

cModuleGlobalVariables :: ModulePtr -> IO [ValuePtr]
cModuleGlobalVariables m =
  peekArray m {#get CModule->globalVariables#} {#get CModule->numGlobalVariables#}

cModuleGlobalAliases :: ModulePtr -> IO [ValuePtr]
cModuleGlobalAliases m =
  peekArray m ({#get CModule->globalAliases#}) ({#get CModule->numGlobalAliases#})

cModuleFunctions :: ModulePtr -> IO [ValuePtr]
cModuleFunctions m =
  peekArray m ({#get CModule->functions#}) ({#get CModule->numFunctions#})

cModuleEnumMetadata :: ModulePtr -> IO [MetaPtr]
cModuleEnumMetadata m =
  peekArray m {#get CModule->enumMetadata#} {#get CModule->numEnumMetadata#}

cModuleRetainedTypeMetadata :: ModulePtr -> IO [MetaPtr]
cModuleRetainedTypeMetadata m =
  peekArray m {#get CModule->retainedTypeMetadata#} {#get CModule->numRetainedTypes#}

cModuleTypes :: ModulePtr -> IO [TypePtr]
cModuleTypes m =
  peekArray m {#get CModule->types#} {#get CModule->numTypes#}

peekArray :: forall a b c e . (Integral c, Storable e) =>
             a -> (a -> IO (Ptr b)) -> (a -> IO c) -> IO [e]
peekArray obj arrAccessor sizeAccessor = do
  nElts <- sizeAccessor obj
  arrPtr <- arrAccessor obj
  case nElts == 0 || arrPtr == nullPtr of
    True -> return []
    False -> do
      fArrPtr <- newForeignPtr_ (castPtr arrPtr)
      let elementCount :: Int
          elementCount = fromIntegral nElts
      arr <- unsafeForeignPtrToStorableArray fArrPtr (1, elementCount)
      getElems arr

data CType
{#pointer *CType as TypePtr -> CType #}
cTypeTag :: TypePtr -> IO TypeTag
cTypeTag t = toEnum . fromIntegral <$> {#get CType->typeTag#} t
cTypeSize :: TypePtr -> IO Int
cTypeSize t = fromIntegral <$> {#get CType->size#} t
cTypeIsVarArg :: TypePtr -> IO Bool
cTypeIsVarArg t = toBool <$> {#get CType->isVarArg#} t
cTypeIsPacked :: TypePtr -> IO Bool
cTypeIsPacked t = toBool <$> {#get CType->isPacked#} t
cTypeList :: TypePtr -> IO [TypePtr]
cTypeList t =
  peekArray t {#get CType->typeList#} {#get CType->typeListLen#}
cTypeInner :: TypePtr -> IO TypePtr
cTypeInner = {#get CType->innerType#}
cTypeName :: TypePtr -> IO (Maybe String)
cTypeName t = do
  n <- optionalField {#get CType->name#} t
  case n of
    Nothing -> return Nothing
    Just n' -> do
      s <- peekCString n'
      return (Just s)
cTypeAddrSpace :: TypePtr -> IO Int
cTypeAddrSpace t = fromIntegral <$> {#get CType->addrSpace#} t

cTypeSizeInBytes :: TypePtr -> IO Int
cTypeSizeInBytes t = fromIntegral <$> {#get CType->sizeInBytes#} t

data CValue
{#pointer *CValue as ValuePtr -> CValue #}
data CMeta
{#pointer *CMeta as MetaPtr -> CMeta #}

cValueTag :: ValuePtr -> IO ValueTag
cValueTag v = toEnum . fromIntegral <$> ({#get CValue->valueTag#} v)
cValueType :: ValuePtr -> IO TypePtr
cValueType = {#get CValue->valueType#}
cValueName :: (InternString m) => ValuePtr -> m (Maybe Identifier)
cValueName v = do
  tag <- liftIO $ cValueTag v
  namePtr <- liftIO $ ({#get CValue->name#}) v
  case namePtr == nullPtr of
    True -> return Nothing
    False -> do
      rawName <- liftIO $ makeText namePtr
      name <- internString rawName
      rawIdent <- case tag of
        ValFunction -> return $! makeGlobalIdentifier name
        ValGlobalvariable -> return $! makeGlobalIdentifier name
        ValAlias -> return $!  makeGlobalIdentifier name
        _ -> return $! makeLocalIdentifier name
      ident <- internIdentifier rawIdent
      return $! (Just ident)
cValueMetadata :: ValuePtr -> IO [MetaPtr]
cValueMetadata v = peekArray v {#get CValue->md#} {#get CValue->numMetadata#}
cValueSrcLoc :: ValuePtr -> IO MetaPtr
cValueSrcLoc = {#get CValue->srcLoc#}
cValueData :: ValuePtr -> IO (Ptr ())
cValueData = {#get CValue->data#}

cMetaTypeTag :: MetaPtr -> IO MetaTag
cMetaTypeTag v = toEnum . fromIntegral <$> {#get CMeta->metaTag #} v

cMetaTag :: MetaPtr -> IO DW_TAG
cMetaTag p = do
  t <- {#get CMeta->tag#} p
  case dw_tag t of
    Nothing -> return DW_TAG_unspecified_type
    Just t' -> return t'

cMetaArrayElts :: MetaPtr -> IO [Maybe MetaPtr]
cMetaArrayElts p = map convertNull <$>
  peekArray p {#get CMeta->u.metaArrayInfo.arrayElts#} {#get CMeta->u.metaArrayInfo.arrayLen#}
  where
    convertNull ptr =
      case ptr == nullPtr of
        True -> Nothing
        False -> Just ptr

cMetaEnumeratorName :: InternString m => MetaPtr -> m Text
cMetaEnumeratorName = shareString {#get CMeta->u.metaEnumeratorInfo.enumName#}
cMetaEnumeratorValue :: MetaPtr -> IO Int64
cMetaEnumeratorValue p = fromIntegral <$> {#get CMeta->u.metaEnumeratorInfo.enumValue#} p
cMetaGlobalContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaGlobalContext = optionalField {#get CMeta->u.metaGlobalInfo.context #}
cMetaGlobalName :: InternString m => MetaPtr -> m Text
cMetaGlobalName = shareString {#get CMeta->u.metaGlobalInfo.name#}
cMetaGlobalDisplayName :: InternString m => MetaPtr -> m Text
cMetaGlobalDisplayName = shareString {#get CMeta->u.metaGlobalInfo.displayName#}
cMetaGlobalLinkageName :: InternString m => MetaPtr -> m Text
cMetaGlobalLinkageName = shareString {#get CMeta->u.metaGlobalInfo.linkageName#}
-- cMetaGlobalCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaGlobalCompileUnit = {#get CMeta->u.metaGlobalInfo.compileUnit#}
cMetaGlobalLine :: MetaPtr -> IO Int32
cMetaGlobalLine p = fromIntegral <$> {#get CMeta->u.metaGlobalInfo.lineNumber#} p
cMetaGlobalType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaGlobalType = optionalField {#get CMeta->u.metaGlobalInfo.globalType#}
cMetaGlobalIsLocal :: MetaPtr -> IO Bool
cMetaGlobalIsLocal p = toBool <$> {#get CMeta->u.metaGlobalInfo.isLocalToUnit#} p
cMetaGlobalIsDefinition :: MetaPtr -> IO Bool
cMetaGlobalIsDefinition p = toBool <$> {#get CMeta->u.metaGlobalInfo.isDefinition#} p
cMetaLocationLine :: MetaPtr -> IO Int32
cMetaLocationLine p = fromIntegral <$> {#get CMeta->u.metaLocationInfo.lineNumber#} p
cMetaLocationColumn :: MetaPtr -> IO Int32
cMetaLocationColumn p = fromIntegral <$> {#get CMeta->u.metaLocationInfo.columnNumber#} p
cMetaLocationScope :: MetaPtr -> IO (Maybe MetaPtr)
cMetaLocationScope = optionalField {#get CMeta->u.metaLocationInfo.scope#}
cMetaSubrangeLo :: MetaPtr -> IO Int64
cMetaSubrangeLo p = fromIntegral <$> {#get CMeta->u.metaSubrangeInfo.lo#} p
cMetaSubrangeHi :: MetaPtr -> IO Int64
cMetaSubrangeHi p = fromIntegral <$> {#get CMeta->u.metaSubrangeInfo.hi#} p
cMetaTemplateTypeContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateTypeContext = optionalField {#get CMeta->u.metaTemplateTypeInfo.context#}
cMetaTemplateTypeName :: InternString m => MetaPtr -> m Text
cMetaTemplateTypeName = shareString {#get CMeta->u.metaTemplateTypeInfo.name#}
cMetaTemplateTypeType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateTypeType = optionalField {#get CMeta->u.metaTemplateTypeInfo.type#}
cMetaTemplateTypeLine :: MetaPtr -> IO Int32
cMetaTemplateTypeLine p = fromIntegral <$> {#get CMeta->u.metaTemplateTypeInfo.lineNumber#} p
cMetaTemplateTypeColumn :: MetaPtr -> IO Int32
cMetaTemplateTypeColumn p = fromIntegral <$> {#get CMeta->u.metaTemplateTypeInfo.columnNumber#} p
cMetaTemplateValueContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateValueContext = optionalField {#get CMeta->u.metaTemplateValueInfo.context#}
cMetaTemplateValueName :: InternString m => MetaPtr -> m Text
cMetaTemplateValueName = shareString {#get CMeta->u.metaTemplateValueInfo.name#}
cMetaTemplateValueType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTemplateValueType = optionalField {#get CMeta->u.metaTemplateValueInfo.type#}
cMetaTemplateValueValue :: MetaPtr -> IO Int64
cMetaTemplateValueValue p = fromIntegral <$> {#get CMeta->u.metaTemplateValueInfo.value#} p
cMetaTemplateValueLine :: MetaPtr -> IO Int32
cMetaTemplateValueLine p = fromIntegral <$> {#get CMeta->u.metaTemplateValueInfo.lineNumber#} p
cMetaTemplateValueColumn :: MetaPtr -> IO Int32
cMetaTemplateValueColumn p = fromIntegral <$> {#get CMeta->u.metaTemplateValueInfo.columnNumber#} p
cMetaVariableContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaVariableContext = optionalField {#get CMeta->u.metaVariableInfo.context#}
cMetaVariableName :: InternString m => MetaPtr -> m Text
cMetaVariableName = shareString {#get CMeta->u.metaVariableInfo.name#}
-- cMetaVariableCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaVariableCompileUnit = {#get CMeta->u.metaVariableInfo.compileUnit#}
cMetaVariableLine :: MetaPtr -> IO Int32
cMetaVariableLine p = fromIntegral <$> {#get CMeta->u.metaVariableInfo.lineNumber#} p
cMetaVariableArgNumber :: MetaPtr -> IO Int32
cMetaVariableArgNumber p = fromIntegral <$> {#get CMeta->u.metaVariableInfo.argNumber#} p
cMetaVariableType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaVariableType = optionalField {#get CMeta->u.metaVariableInfo.type#}
cMetaVariableIsArtificial :: MetaPtr -> IO Bool
cMetaVariableIsArtificial p = toBool <$> {#get CMeta->u.metaVariableInfo.isArtificial#} p
cMetaVariableHasComplexAddress :: MetaPtr -> IO Bool
cMetaVariableHasComplexAddress p = toBool <$> {#get CMeta->u.metaVariableInfo.hasComplexAddress #} p
cMetaVariableAddrElements :: MetaPtr -> IO [Int64]
cMetaVariableAddrElements p = do
  ca <- cMetaVariableHasComplexAddress p
  case ca of
    True -> peekArray p {#get CMeta->u.metaVariableInfo.addrElements#} {#get CMeta->u.metaVariableInfo.numAddrElements#}
    False -> return []
cMetaVariableIsBlockByRefVar :: MetaPtr -> IO Bool
cMetaVariableIsBlockByRefVar p = toBool <$> {#get CMeta->u.metaVariableInfo.isBlockByRefVar#} p
cMetaCompileUnitLanguage :: MetaPtr -> IO DW_LANG
cMetaCompileUnitLanguage p = dw_lang <$> {#get CMeta->u.metaCompileUnitInfo.language#} p
cMetaCompileUnitFilename :: InternString m => MetaPtr -> m Text
cMetaCompileUnitFilename = shareString {#get CMeta->u.metaCompileUnitInfo.filename#}
cMetaCompileUnitDirectory :: InternString m => MetaPtr -> m Text
cMetaCompileUnitDirectory = shareString {#get CMeta->u.metaCompileUnitInfo.directory#}
cMetaCompileUnitProducer :: InternString m => MetaPtr -> m Text
cMetaCompileUnitProducer = shareString {#get CMeta->u.metaCompileUnitInfo.producer#}
cMetaCompileUnitIsMain :: MetaPtr -> IO Bool
cMetaCompileUnitIsMain p = toBool <$> {#get CMeta->u.metaCompileUnitInfo.isMain#} p
cMetaCompileUnitIsOptimized :: MetaPtr -> IO Bool
cMetaCompileUnitIsOptimized p = toBool <$> {#get CMeta->u.metaCompileUnitInfo.isOptimized#} p
cMetaCompileUnitFlags :: InternString m => MetaPtr -> m Text
cMetaCompileUnitFlags = shareString {#get CMeta->u.metaCompileUnitInfo.flags#}
cMetaCompileUnitRuntimeVersion :: MetaPtr -> IO Int32
cMetaCompileUnitRuntimeVersion p = fromIntegral <$> {#get CMeta->u.metaCompileUnitInfo.runtimeVersion#} p
cMetaCompileUnitEnumTypes :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitEnumTypes = optionalField {#get CMeta->u.metaCompileUnitInfo.enumTypes#}
cMetaCompileUnitRetainedTypes :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitRetainedTypes = optionalField {#get CMeta->u.metaCompileUnitInfo.retainedTypes#}
cMetaCompileUnitSubprograms :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitSubprograms = optionalField {#get CMeta->u.metaCompileUnitInfo.subprograms#}
cMetaCompileUnitGlobalVariables :: MetaPtr -> IO (Maybe MetaPtr)
cMetaCompileUnitGlobalVariables = optionalField {#get CMeta->u.metaCompileUnitInfo.globalVariables#}
cMetaFileFilename :: InternString m => MetaPtr -> m Text
cMetaFileFilename = shareString {#get CMeta->u.metaFileInfo.filename#}
cMetaFileDirectory :: InternString m => MetaPtr -> m Text
cMetaFileDirectory = shareString {#get CMeta->u.metaFileInfo.directory#}
-- cMetaFileCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaFileCompileUnit = {#get CMeta->u.metaFileInfo.compileUnit#}
cMetaLexicalBlockContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaLexicalBlockContext = optionalField {#get CMeta->u.metaLexicalBlockInfo.context#}
cMetaLexicalBlockLine :: MetaPtr -> IO Int32
cMetaLexicalBlockLine p = fromIntegral <$> {#get CMeta->u.metaLexicalBlockInfo.lineNumber#} p
cMetaLexicalBlockColumn :: MetaPtr -> IO Int32
cMetaLexicalBlockColumn p = fromIntegral <$> {#get CMeta->u.metaLexicalBlockInfo.columnNumber#} p
cMetaNamespaceContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaNamespaceContext = optionalField {#get CMeta->u.metaNamespaceInfo.context#}
cMetaNamespaceName :: InternString m => MetaPtr -> m Text
cMetaNamespaceName = shareString {#get CMeta->u.metaNamespaceInfo.name#}
-- cMetaNamespaceCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaNamespaceCompileUnit = {#get CMeta->u.metaNamespaceInfo.compileUnit#}
cMetaNamespaceLine :: MetaPtr -> IO Int32
cMetaNamespaceLine p = fromIntegral <$> {#get CMeta->u.metaNamespaceInfo.lineNumber#} p
cMetaSubprogramContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaSubprogramContext = optionalField {#get CMeta->u.metaSubprogramInfo.context#}
cMetaSubprogramName :: InternString m => MetaPtr -> m Text
cMetaSubprogramName = shareString {#get CMeta->u.metaSubprogramInfo.name#}
cMetaSubprogramDisplayName :: InternString m => MetaPtr -> m Text
cMetaSubprogramDisplayName = shareString {#get CMeta->u.metaSubprogramInfo.displayName#}
cMetaSubprogramLinkageName :: InternString m => MetaPtr -> m Text
cMetaSubprogramLinkageName = shareString {#get CMeta->u.metaSubprogramInfo.linkageName#}
-- cMetaSubprogramCompileUnit :: MetaPtr -> IO MetaPtr
-- cMetaSubprogramCompileUnit = {#get CMeta->u.metaSubprogramInfo.compileUnit#}
cMetaSubprogramLine :: MetaPtr -> IO Int32
cMetaSubprogramLine p = fromIntegral <$> {#get CMeta->u.metaSubprogramInfo.lineNumber#} p
cMetaSubprogramType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaSubprogramType = optionalField {#get CMeta->u.metaSubprogramInfo.type#}
cMetaSubprogramIsLocal :: MetaPtr -> IO Bool
cMetaSubprogramIsLocal p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isLocalToUnit#} p
cMetaSubprogramIsDefinition :: MetaPtr -> IO Bool
cMetaSubprogramIsDefinition p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isDefinition#} p
cMetaSubprogramVirtuality :: MetaPtr -> IO DW_VIRTUALITY
cMetaSubprogramVirtuality p = dw_virtuality <$> {#get CMeta->u.metaSubprogramInfo.virtuality#} p
cMetaSubprogramVirtualIndex :: MetaPtr -> IO Int32
cMetaSubprogramVirtualIndex p = fromIntegral <$> {#get CMeta->u.metaSubprogramInfo.virtualIndex#} p
cMetaSubprogramContainingType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaSubprogramContainingType = optionalField {#get CMeta->u.metaSubprogramInfo.containingType#}
cMetaSubprogramIsArtificial :: MetaPtr -> IO Bool
cMetaSubprogramIsArtificial p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isArtificial#} p
cMetaSubprogramIsPrivate :: MetaPtr -> IO Bool
cMetaSubprogramIsPrivate p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isPrivate#} p
cMetaSubprogramIsProtected :: MetaPtr -> IO Bool
cMetaSubprogramIsProtected p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isProtected#} p
cMetaSubprogramIsExplicit :: MetaPtr -> IO Bool
cMetaSubprogramIsExplicit p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isExplicit#} p
cMetaSubprogramIsPrototyped :: MetaPtr -> IO Bool
cMetaSubprogramIsPrototyped p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isPrototyped#} p
cMetaSubprogramIsOptimized :: MetaPtr -> IO Bool
cMetaSubprogramIsOptimized p = toBool <$> {#get CMeta->u.metaSubprogramInfo.isOptimized#} p
cMetaTypeContext :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeContext = optionalField {#get CMeta->u.metaTypeInfo.context#}
cMetaTypeName :: InternString m => MetaPtr -> m Text
cMetaTypeName = shareString {#get CMeta->u.metaTypeInfo.name#}
-- cMetaTypeCompileUnit :: MetaPtr -> IO (Maybe MetaPtr)
-- cMetaTypeCompileUnit = optionalField {#get CMeta->u.metaTypeInfo.compileUnit#}
-- cMetaTypeFile :: MetaPtr -> IO (Maybe MetaPtr)
-- cMetaTypeFile = optionalField {#get CMeta->u.metaTypeInfo.file#}
cMetaTypeLine :: MetaPtr -> IO Int32
cMetaTypeLine p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.lineNumber#} p
cMetaTypeSize :: MetaPtr -> IO Int64
cMetaTypeSize p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.sizeInBits#} p
cMetaTypeAlign :: MetaPtr -> IO Int64
cMetaTypeAlign p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.alignInBits#} p
cMetaTypeOffset :: MetaPtr -> IO Int64
cMetaTypeOffset p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.offsetInBits#} p
cMetaTypeFlags :: MetaPtr -> IO Int32
cMetaTypeFlags p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.flags#} p
cMetaTypeIsPrivate :: MetaPtr -> IO Bool
cMetaTypeIsPrivate p = toBool <$> {#get CMeta->u.metaTypeInfo.isPrivate#} p
cMetaTypeIsProtected :: MetaPtr -> IO Bool
cMetaTypeIsProtected p = toBool <$> {#get CMeta->u.metaTypeInfo.isProtected#} p
cMetaTypeIsForward :: MetaPtr -> IO Bool
cMetaTypeIsForward p = toBool <$> {#get CMeta->u.metaTypeInfo.isForward#} p
cMetaTypeIsByRefStruct :: MetaPtr -> IO Bool
cMetaTypeIsByRefStruct p = toBool <$> {#get CMeta->u.metaTypeInfo.isByRefStruct#} p
cMetaTypeIsVirtual :: MetaPtr -> IO Bool
cMetaTypeIsVirtual p = toBool <$> {#get CMeta->u.metaTypeInfo.isVirtual#} p
cMetaTypeIsArtificial :: MetaPtr -> IO Bool
cMetaTypeIsArtificial p = toBool <$> {#get CMeta->u.metaTypeInfo.isArtificial#} p
cMetaTypeDirectory :: InternString m => MetaPtr -> m Text
cMetaTypeDirectory = shareString {#get CMeta->u.metaTypeInfo.directory#}
cMetaTypeFilename :: InternString m => MetaPtr -> m Text
cMetaTypeFilename = shareString {#get CMeta->u.metaTypeInfo.filename#}
cMetaTypeEncoding :: MetaPtr -> IO DW_ATE
cMetaTypeEncoding p = dw_ate <$> {#get CMeta->u.metaTypeInfo.encoding#} p
cMetaTypeDerivedFrom :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeDerivedFrom = optionalField {#get CMeta->u.metaTypeInfo.typeDerivedFrom#}
cMetaTypeCompositeComponents :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeCompositeComponents = optionalField {#get CMeta->u.metaTypeInfo.typeArray#}
cMetaTypeRuntimeLanguage :: MetaPtr -> IO Int32
cMetaTypeRuntimeLanguage p = fromIntegral <$> {#get CMeta->u.metaTypeInfo.runTimeLang#} p
cMetaTypeContainingType :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeContainingType = optionalField {#get CMeta->u.metaTypeInfo.containingType#}
cMetaTypeTemplateParams :: MetaPtr -> IO (Maybe MetaPtr)
cMetaTypeTemplateParams = optionalField {#get CMeta->u.metaTypeInfo.templateParams#}
cMetaUnknownRepr :: InternString m => MetaPtr -> m Text
cMetaUnknownRepr = shareString {#get CMeta->u.metaUnknownInfo.repr#}

optionalField :: (a -> IO (Ptr b)) -> a -> IO (Maybe (Ptr b))
optionalField accessor p = do
  v <- accessor p
  case v == nullPtr of
    True -> return Nothing
    False -> return (Just v)

class MonadIO m => InternString m where
  internString :: Text -> m Text
  internIdentifier :: Identifier -> m Identifier

-- | This helper converts C char* strings into Texts, sharing
-- identical bytestrings on the Haskell side.  This is a simple
-- space-saving optimization (assuming the entire cache is garbage
-- collected)
shareString :: InternString m => (a -> IO CString) -> a -> m Text
shareString accessor ptr = do
  sp <- liftIO $ accessor ptr
  when (sp == nullPtr) (error "Null ptr in string")
  str <- liftIO $ BS.packCString sp
  internString (decodeUtf8 str)

data CGlobalInfo
{#pointer *CGlobalInfo as GlobalInfoPtr -> CGlobalInfo #}
cGlobalIsExternal :: GlobalInfoPtr -> IO Bool
cGlobalIsExternal g = toBool <$> ({#get CGlobalInfo->isExternal#} g)
cGlobalAlignment :: GlobalInfoPtr -> IO Int64
cGlobalAlignment g = fromIntegral <$> ({#get CGlobalInfo->alignment#} g)
cGlobalVisibility :: GlobalInfoPtr -> IO VisibilityStyle
cGlobalVisibility g = toEnum . fromIntegral <$> ({#get CGlobalInfo->visibility#} g)
cGlobalLinkage :: GlobalInfoPtr -> IO LinkageType
cGlobalLinkage g = toEnum . fromIntegral <$> ({#get CGlobalInfo->linkage#} g)
cGlobalSection :: GlobalInfoPtr -> IO (Maybe Text)
cGlobalSection g = do
  s <- {#get CGlobalInfo->section#} g
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just (decodeUtf8 bs)
cGlobalInitializer :: GlobalInfoPtr -> IO ValuePtr
cGlobalInitializer = {#get CGlobalInfo->initializer#}
cGlobalIsThreadLocal :: GlobalInfoPtr -> IO Bool
cGlobalIsThreadLocal g = toBool <$> ({#get CGlobalInfo->isThreadLocal#} g)
cGlobalAliasee :: GlobalInfoPtr -> IO ValuePtr
cGlobalAliasee = {#get CGlobalInfo->aliasee#}
cGlobalIsConstant :: GlobalInfoPtr -> IO Bool
cGlobalIsConstant g = toBool <$> {#get CGlobalInfo->isConstant#} g

data CFunctionInfo
{#pointer *CFunctionInfo as FunctionInfoPtr -> CFunctionInfo #}
cFunctionIsExternal :: FunctionInfoPtr -> IO Bool
cFunctionIsExternal f = toBool <$> {#get CFunctionInfo->isExternal#} f
cFunctionAlignment :: FunctionInfoPtr -> IO Int64
cFunctionAlignment f = fromIntegral <$> {#get CFunctionInfo->alignment#} f
cFunctionVisibility :: FunctionInfoPtr -> IO VisibilityStyle
cFunctionVisibility f = toEnum . fromIntegral <$> {#get CFunctionInfo->visibility#} f
cFunctionLinkage :: FunctionInfoPtr -> IO LinkageType
cFunctionLinkage f = toEnum . fromIntegral <$> {#get CFunctionInfo->linkage#} f
cFunctionSection :: FunctionInfoPtr -> IO (Maybe Text)
cFunctionSection f = do
  s <- {#get CFunctionInfo->section#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just (decodeUtf8 bs)
cFunctionIsVarArg :: FunctionInfoPtr -> IO Bool
cFunctionIsVarArg f = toBool <$> {#get CFunctionInfo->isVarArg#} f
cFunctionCallingConvention :: FunctionInfoPtr -> IO CallingConvention
cFunctionCallingConvention f = toEnum . fromIntegral <$> {#get CFunctionInfo->callingConvention#} f
cFunctionGCName :: FunctionInfoPtr -> IO (Maybe Text)
cFunctionGCName f = do
  s <- {#get CFunctionInfo->gcName#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just (decodeUtf8 bs)
cFunctionArguments :: FunctionInfoPtr -> IO [ValuePtr]
cFunctionArguments f =
  peekArray f {#get CFunctionInfo->arguments#} {#get CFunctionInfo->argListLen#}
cFunctionBlocks :: FunctionInfoPtr -> IO [ValuePtr]
cFunctionBlocks f =
  peekArray f {#get CFunctionInfo->body#} {#get CFunctionInfo->blockListLen#}

data CArgInfo
{#pointer *CArgumentInfo as ArgInfoPtr -> CArgInfo #}
cArgInfoHasSRet :: ArgInfoPtr -> IO Bool
cArgInfoHasSRet a = toBool <$> ({#get CArgumentInfo->hasSRet#} a)
cArgInfoHasByVal :: ArgInfoPtr -> IO Bool
cArgInfoHasByVal a = toBool <$> ({#get CArgumentInfo->hasByVal#} a)
cArgInfoHasNest :: ArgInfoPtr -> IO Bool
cArgInfoHasNest a = toBool <$> ({#get CArgumentInfo->hasNest#} a)
cArgInfoHasNoAlias :: ArgInfoPtr -> IO Bool
cArgInfoHasNoAlias a = toBool <$> ({#get CArgumentInfo->hasNoAlias#} a)
cArgInfoHasNoCapture :: ArgInfoPtr -> IO Bool
cArgInfoHasNoCapture a = toBool <$> ({#get CArgumentInfo->hasNoCapture#} a)

data CBasicBlockInfo
{#pointer *CBasicBlockInfo as BasicBlockPtr -> CBasicBlockInfo #}

cBasicBlockInstructions :: BasicBlockPtr -> IO [ValuePtr]
cBasicBlockInstructions b =
  peekArray b {#get CBasicBlockInfo->instructions#} {#get CBasicBlockInfo->blockLen#}

data CInlineAsmInfo
{#pointer *CInlineAsmInfo as InlineAsmInfoPtr -> CInlineAsmInfo #}

cInlineAsmString :: InlineAsmInfoPtr -> IO Text
cInlineAsmString a =
  ({#get CInlineAsmInfo->asmString#} a) >>= makeText
cInlineAsmConstraints :: InlineAsmInfoPtr -> IO Text
cInlineAsmConstraints a =
  ({#get CInlineAsmInfo->constraintString#} a) >>= makeText

data CBlockAddrInfo
{#pointer *CBlockAddrInfo as BlockAddrInfoPtr -> CBlockAddrInfo #}

cBlockAddrFunc :: BlockAddrInfoPtr -> IO ValuePtr
cBlockAddrFunc = {#get CBlockAddrInfo->func #}
cBlockAddrBlock :: BlockAddrInfoPtr -> IO ValuePtr
cBlockAddrBlock = {#get CBlockAddrInfo->block #}

data CAggregateInfo
{#pointer *CConstAggregate as AggregateInfoPtr -> CAggregateInfo #}

cAggregateValues :: AggregateInfoPtr -> IO [ValuePtr]
cAggregateValues a =
  peekArray a {#get CConstAggregate->constants#} {#get CConstAggregate->numElements#}

data CConstFP
{#pointer *CConstFP as FPInfoPtr -> CConstFP #}
cFPVal :: FPInfoPtr -> IO Double
cFPVal f = realToFrac <$> ({#get CConstFP->val#} f)

data CConstInt
{#pointer *CConstInt as IntInfoPtr -> CConstInt #}
cIntVal :: IntInfoPtr -> IO Integer
cIntVal i = fromIntegral <$> ({#get CConstInt->val#} i)
cIntHugeVal :: IntInfoPtr -> IO (Maybe Integer)
cIntHugeVal i = do
  s <- {#get CConstInt->hugeVal#} i
  case s == nullPtr of
    True -> return Nothing
    False -> (Just . read) <$> peekCString s

data CInstructionInfo
{#pointer *CInstructionInfo as InstInfoPtr -> CInstructionInfo #}
cInstructionOperands :: InstInfoPtr -> IO [ValuePtr]
cInstructionOperands i =
  peekArray i {#get CInstructionInfo->operands#} {#get CInstructionInfo->numOperands#}
cInstructionArithFlags :: InstInfoPtr -> IO ArithFlags
cInstructionArithFlags o = toEnum . fromIntegral <$> {#get CInstructionInfo->flags#} o
cInstructionAlign :: InstInfoPtr -> IO Int64
cInstructionAlign u = fromIntegral <$> {#get CInstructionInfo->align#} u
cInstructionIsVolatile :: InstInfoPtr -> IO Bool
cInstructionIsVolatile u = toBool <$> {#get CInstructionInfo->isVolatile#} u
cInstructionAddrSpace :: InstInfoPtr -> IO Int
cInstructionAddrSpace u = fromIntegral <$> {#get CInstructionInfo->addrSpace#} u
cInstructionCmpPred :: InstInfoPtr -> IO CmpPredicate
cInstructionCmpPred c = toEnum . fromIntegral <$> {#get CInstructionInfo->cmpPred#} c
cInstructionInBounds :: InstInfoPtr -> IO Bool
cInstructionInBounds g = toBool <$> {#get CInstructionInfo->inBounds#} g
cInstructionIndices :: InstInfoPtr -> IO [Int]
cInstructionIndices i =
  peekArray i {#get CInstructionInfo->indices#} {#get CInstructionInfo->numIndices#}

data CConstExprInfo
{#pointer *CConstExprInfo as ConstExprPtr -> CConstExprInfo #}
cConstExprTag :: ConstExprPtr -> IO ValueTag
cConstExprTag e = toEnum . fromIntegral <$> {#get CConstExprInfo->instrType#} e
cConstExprInstInfo :: ConstExprPtr -> IO InstInfoPtr
cConstExprInstInfo = {#get CConstExprInfo->ii#}

data CPHIInfo
{#pointer *CPHIInfo as PHIInfoPtr -> CPHIInfo #}
cPHIValues :: PHIInfoPtr -> IO [ValuePtr]
cPHIValues p =
  peekArray p {#get CPHIInfo->incomingValues#} {#get CPHIInfo->numIncomingValues#}
cPHIBlocks :: PHIInfoPtr -> IO [ValuePtr]
cPHIBlocks p =
  peekArray p {#get CPHIInfo->valueBlocks#} {#get CPHIInfo->numIncomingValues#}

data CCallInfo
{#pointer *CCallInfo as CallInfoPtr -> CCallInfo #}
cCallValue :: CallInfoPtr -> IO ValuePtr
cCallValue = {#get CCallInfo->calledValue #}
cCallArguments :: CallInfoPtr -> IO [ValuePtr]
cCallArguments c =
  peekArray c {#get CCallInfo->arguments#} {#get CCallInfo->argListLen#}
cCallConvention :: CallInfoPtr -> IO CallingConvention
cCallConvention c = toEnum . fromIntegral <$> {#get CCallInfo->callingConvention#} c
cCallHasSRet :: CallInfoPtr -> IO Bool
cCallHasSRet c = toBool <$> {#get CCallInfo->hasSRet#} c
cCallIsTail :: CallInfoPtr -> IO Bool
cCallIsTail c = toBool <$> {#get CCallInfo->isTail#} c
cCallUnwindDest :: CallInfoPtr -> IO ValuePtr
cCallUnwindDest = {#get CCallInfo->unwindDest#}
cCallNormalDest :: CallInfoPtr -> IO ValuePtr
cCallNormalDest = {#get CCallInfo->normalDest#}

data CAtomicInfo
{#pointer *CAtomicInfo as AtomicInfoPtr -> CAtomicInfo #}
cAtomicOrdering :: AtomicInfoPtr -> IO AtomicOrdering
cAtomicOrdering ai = toEnum . fromIntegral <$> {#get CAtomicInfo->ordering#} ai
cAtomicScope :: AtomicInfoPtr -> IO SynchronizationScope
cAtomicScope ai = toEnum . fromIntegral <$> {#get CAtomicInfo->scope#} ai
cAtomicOperation :: AtomicInfoPtr -> IO AtomicOperation
cAtomicOperation ai = toEnum . fromIntegral <$> {#get CAtomicInfo->operation#} ai
cAtomicIsVolatile :: AtomicInfoPtr -> IO Bool
cAtomicIsVolatile ai = toBool <$> {#get CAtomicInfo->isVolatile#} ai
cAtomicAddressSpace :: AtomicInfoPtr -> IO Int
cAtomicAddressSpace ai = fromIntegral <$> {#get CAtomicInfo->addrSpace#} ai
cAtomicPointerOperand :: AtomicInfoPtr -> IO ValuePtr
cAtomicPointerOperand = {#get CAtomicInfo->pointerOperand#}
cAtomicValueOperand :: AtomicInfoPtr -> IO ValuePtr
cAtomicValueOperand = {#get CAtomicInfo->valueOperand#}
cAtomicCompareOperand :: AtomicInfoPtr -> IO ValuePtr
cAtomicCompareOperand = {#get CAtomicInfo->compareOperand#}

data CLandingPadInfo
{#pointer *CLandingPadInfo as LandingPadInfoPtr -> CLandingPadInfo#}
cLandingPadPersonality :: LandingPadInfoPtr -> IO ValuePtr
cLandingPadPersonality = {#get CLandingPadInfo->personality#}
cLandingPadIsCleanup :: LandingPadInfoPtr -> IO Bool
cLandingPadIsCleanup li = toBool <$> {#get CLandingPadInfo->isCleanup#} li
cLandingPadClauses :: LandingPadInfoPtr -> IO [ValuePtr]
cLandingPadClauses li =
  peekArray li {#get CLandingPadInfo->clauses #} {#get CLandingPadInfo->numClauses#}
cLandingPadClauseTypes :: LandingPadInfoPtr -> IO [LandingPadClause]
cLandingPadClauseTypes li = do
  arr <- peekArray li {#get CLandingPadInfo->clauseTypes #} {#get CLandingPadInfo->numClauses#}
  return $ map toEnum arr

-- | Parse the named file into an FFI-friendly representation of an
-- LLVM module.
{#fun marshalLLVM { id `Ptr CChar', `Int',  fromBool `Bool' } -> `ModulePtr' id #}
{#fun marshalLLVMFile { `String', fromBool `Bool' } -> `ModulePtr' id #}

-- | Free all of the resources allocated by 'marshalLLVM'
{#fun disposeCModule { id `ModulePtr' } -> `()' #}

-- Helpers

-- This only seems to be necessary on i386 for some reason.
cIntConv :: (Integral a, Num b) => a -> b
cIntConv = fromIntegral


Add property functions for Char type

Add property functions for Char type

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library 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
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyChar,
  objectGetPropertyChar,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyBoxedOpaque,
  objectGetPropertyBoxedOpaque,
  objectSetPropertyBoxedStorable,
  objectGetPropertyBoxedStorable,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  newAttrFromCharProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  writeAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  writeAttrFromMaybeStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromBoxedOpaqueProperty,
  writeAttrFromBoxedOpaqueProperty,
  newAttrFromBoxedStorableProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,

  -- TODO: do not export these once we dump the old TreeList API:
  objectGetPropertyInternal,
  objectSetPropertyInternal,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

{# context lib="glib" prefix="g" #}

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call unsafe g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyChar :: GObjectClass gobj => String -> gobj -> Char -> IO ()
objectSetPropertyChar = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral (fromEnum v)))

objectGetPropertyChar :: GObjectClass gobj => String -> gobj -> IO Char
objectGetPropertyChar = objectGetPropertyInternal GType.uint (\gv -> liftM (toEnum . fromIntegral) $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with)

objectGetPropertyBoxedOpaque :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedOpaque peek gtype = objectGetPropertyInternal gtype (valueGetBoxed peek)

objectSetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedStorable = objectSetPropertyBoxedOpaque with

objectGetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedStorable = objectGetPropertyBoxedOpaque peek

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

newAttrFromCharProperty :: GObjectClass gobj => String -> Attr gobj Char
newAttrFromCharProperty propName =
  newAttr (objectGetPropertyChar propName) (objectSetPropertyChar propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

writeAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> WriteAttr gobj enum
writeAttrFromEnumProperty propName gtype =
  writeAttr (objectSetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String)
writeAttrFromMaybeStringProperty propName =
  writeAttr (objectSetPropertyMaybeString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed
newAttrFromBoxedOpaqueProperty peek with propName gtype =
  newAttr (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName)

writeAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> WriteAttr gobj boxed
writeAttrFromBoxedOpaqueProperty with propName gtype =
  writeAttr (objectSetPropertyBoxedOpaque with gtype propName)

newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed
newAttrFromBoxedStorableProperty propName gtype =
  newAttr (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library 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
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyBoxedOpaque,
  objectGetPropertyBoxedOpaque,
  objectSetPropertyBoxedStorable,
  objectGetPropertyBoxedStorable,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  writeAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  writeAttrFromMaybeStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromBoxedOpaqueProperty,
  writeAttrFromBoxedOpaqueProperty,
  newAttrFromBoxedStorableProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,

  -- TODO: do not export these once we dump the old TreeList API:
  objectGetPropertyInternal,
  objectSetPropertyInternal,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

{# context lib="glib" prefix="g" #}

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call unsafe g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with)

objectGetPropertyBoxedOpaque :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedOpaque peek gtype = objectGetPropertyInternal gtype (valueGetBoxed peek)

objectSetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedStorable = objectSetPropertyBoxedOpaque with

objectGetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedStorable = objectGetPropertyBoxedOpaque peek

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

writeAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> WriteAttr gobj enum
writeAttrFromEnumProperty propName gtype =
  writeAttr (objectSetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String)
writeAttrFromMaybeStringProperty propName =
  writeAttr (objectSetPropertyMaybeString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed
newAttrFromBoxedOpaqueProperty peek with propName gtype =
  newAttr (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName)

writeAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> WriteAttr gobj boxed
writeAttrFromBoxedOpaqueProperty with propName gtype =
  writeAttr (objectSetPropertyBoxedOpaque with gtype propName)

newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed
newAttrFromBoxedStorableProperty propName gtype =
  newAttr (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)