add maximum registers per thread to device data table

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include <cuda.h>

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
#if CUDA_VERSION >= 4000
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#else
    canMapHostMemory            :: !Bool                -- ^ Device can use pinned memory
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp      :: !Int,        -- ^ Warp size
    threadsPerMP        :: !Int,        -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP   :: !Int,        -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP          :: !Int,        -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP          :: !Int,        -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP      :: !Int,        -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit  :: !Int,        -- ^ Shared memory allocation unit size (bytes)
    regFileSize         :: !Int,        -- ^ Total number of registers in a multiprocessor
    regAllocUnit        :: !Int,        -- ^ Register allocation unit size
    regAllocWarp        :: !Int,        -- ^ Register allocation granularity for warps
    regPerThread        :: !Int,        -- ^ Maximum number of registers per thread
    allocation          :: !Allocation  -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2  63 Warp   -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2  63 Warp   -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4  63 Warp   -- Kepler GK10x
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Kepler GK11x

      -- Something might have gone wrong, or the library just needs to be
      -- updated for the next generation of hardware, in which case we just want
      -- to pick a sensible default and carry on.
      --
      -- This is slightly dodgy as the warning message is coming from pure code.
      -- However, it should be OK because all library functions run in IO, so it
      -- is likely the user code is as well.
      --
      _           -> trace warning $ resources (Compute 3 0)
        where warning = unlines [ "*** Warning: unknown CUDA device compute capability: " ++ show compute
                                , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include <cuda.h>

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
#if CUDA_VERSION >= 4000
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#else
    canMapHostMemory            :: !Bool                -- ^ Device can use pinned memory
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp     :: !Int,         -- ^ Warp size
    threadsPerMP       :: !Int,         -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP  :: !Int,         -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP         :: !Int,         -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP         :: !Int,         -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP     :: !Int,         -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit :: !Int,         -- ^ Shared memory allocation unit size (bytes)
    regFileSize        :: !Int,         -- ^ Total number of registers in a multiprocessor
    regAllocUnit       :: !Int,         -- ^ Register allocation unit size
    regAllocWarp       :: !Int,         -- ^ Register allocation granularity for warps
    allocation         :: !Allocation   -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 Block      -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 Block      -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 Block      -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 Block      -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2 Warp       -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2 Warp       -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 Warp       -- Kepler GK10x
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 Warp       -- Kepler GK11x

      -- Something might have gone wrong, or the library just needs to be
      -- updated for the next generation of hardware, in which case we just want
      -- to pick a sensible default and carry on.
      --
      -- This is slightly dodgy as the warning message is coming from pure code.
      -- However, it should be OK because all library functions run in IO, so it
      -- is likely the user code is as well.
      --
      _           -> trace warning $ resources (Compute 3 0)
        where warning = unlines [ "*** Warning: unknown CUDA device compute capability: " ++ show compute
                                , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]


Work with ghc 7.4

Work with ghc 7.4

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

import Control.Applicative
import Control.Monad ( when )
import Control.Monad.Trans ( MonadIO, liftIO )
import Data.Array.Storable ( getElems )
import Data.Array.Unsafe ( unsafeForeignPtrToStorableArray )
import Data.ByteString.Char8 ( ByteString )
import qualified Data.ByteString.Char8 as BS
import Data.Int
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable

import Data.LLVM.Attributes
import Data.LLVM.Dwarf
import Data.LLVM.Identifiers

#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 #}

cModuleIdentifier :: ModulePtr -> IO ByteString
cModuleIdentifier m = ({#get CModule->moduleIdentifier#} m) >>= BS.packCString

cModuleDataLayout :: ModulePtr -> IO ByteString
cModuleDataLayout m = ({#get CModule->moduleDataLayout#} m) >>= BS.packCString

cModuleTargetTriple :: ModulePtr -> IO ByteString
cModuleTargetTriple m = ({#get CModule->targetTriple#} m) >>= BS.packCString

cModuleInlineAsm :: ModulePtr -> IO ByteString
cModuleInlineAsm m = ({#get CModule->moduleInlineAsm#} m) >>= BS.packCString

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#})

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)
      arr <- unsafeForeignPtrToStorableArray fArrPtr (1, fromIntegral nElts)
      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 String
cTypeName t = {#get CType->name#} t >>= peekCString
cTypeAddrSpace :: TypePtr -> IO Int
cTypeAddrSpace t = fromIntegral <$> {#get CType->addrSpace#} t

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

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

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

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

cMetaTag :: MetaPtr -> IO DW_TAG
cMetaTag p = dw_tag <$> {#get CMeta->tag#} p

cMetaArrayElts :: MetaPtr -> IO [MetaPtr]
cMetaArrayElts p =
  peekArray p {#get CMeta->u.metaArrayInfo.arrayElts#} {#get CMeta->u.metaArrayInfo.arrayLen#}
cMetaEnumeratorName :: InternString m => MetaPtr -> m ByteString
cMetaEnumeratorName = shareString {#get CMeta->u.metaEnumeratorInfo.enumName#}
cMetaEnumeratorValue :: MetaPtr -> IO Int64
cMetaEnumeratorValue p = fromIntegral <$> {#get CMeta->u.metaEnumeratorInfo.enumValue#} p
cMetaGlobalContext :: MetaPtr -> IO MetaPtr
cMetaGlobalContext = {#get CMeta->u.metaGlobalInfo.context #}
cMetaGlobalName :: InternString m => MetaPtr -> m ByteString
cMetaGlobalName = shareString {#get CMeta->u.metaGlobalInfo.name#}
cMetaGlobalDisplayName :: InternString m => MetaPtr -> m ByteString
cMetaGlobalDisplayName = shareString {#get CMeta->u.metaGlobalInfo.displayName#}
cMetaGlobalLinkageName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaGlobalType = {#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 MetaPtr
cMetaLocationScope = {#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 MetaPtr
cMetaTemplateTypeContext = {#get CMeta->u.metaTemplateTypeInfo.context#}
cMetaTemplateTypeName :: InternString m => MetaPtr -> m ByteString
cMetaTemplateTypeName = shareString {#get CMeta->u.metaTemplateTypeInfo.name#}
cMetaTemplateTypeType :: MetaPtr -> IO MetaPtr
cMetaTemplateTypeType = {#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 MetaPtr
cMetaTemplateValueContext = {#get CMeta->u.metaTemplateValueInfo.context#}
cMetaTemplateValueName :: InternString m => MetaPtr -> m ByteString
cMetaTemplateValueName = shareString {#get CMeta->u.metaTemplateValueInfo.name#}
cMetaTemplateValueType :: MetaPtr -> IO MetaPtr
cMetaTemplateValueType = {#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 MetaPtr
cMetaVariableContext = {#get CMeta->u.metaVariableInfo.context#}
cMetaVariableName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaVariableType = {#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 ByteString
cMetaCompileUnitFilename = shareString {#get CMeta->u.metaCompileUnitInfo.filename#}
cMetaCompileUnitDirectory :: InternString m => MetaPtr -> m ByteString
cMetaCompileUnitDirectory = shareString {#get CMeta->u.metaCompileUnitInfo.directory#}
cMetaCompileUnitProducer :: InternString m => MetaPtr -> m ByteString
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 ByteString
cMetaCompileUnitFlags = shareString {#get CMeta->u.metaCompileUnitInfo.flags#}
cMetaCompileUnitRuntimeVersion :: MetaPtr -> IO Int32
cMetaCompileUnitRuntimeVersion p = fromIntegral <$> {#get CMeta->u.metaCompileUnitInfo.runtimeVersion#} p
cMetaFileFilename :: InternString m => MetaPtr -> m ByteString
cMetaFileFilename = shareString {#get CMeta->u.metaFileInfo.filename#}
cMetaFileDirectory :: InternString m => MetaPtr -> m ByteString
cMetaFileDirectory = shareString {#get CMeta->u.metaFileInfo.directory#}
cMetaFileCompileUnit :: MetaPtr -> IO MetaPtr
cMetaFileCompileUnit = {#get CMeta->u.metaFileInfo.compileUnit#}
cMetaLexicalBlockContext :: MetaPtr -> IO MetaPtr
cMetaLexicalBlockContext = {#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 MetaPtr
cMetaNamespaceContext = {#get CMeta->u.metaNamespaceInfo.context#}
cMetaNamespaceName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaSubprogramContext = {#get CMeta->u.metaSubprogramInfo.context#}
cMetaSubprogramName :: InternString m => MetaPtr -> m ByteString
cMetaSubprogramName = shareString {#get CMeta->u.metaSubprogramInfo.name#}
cMetaSubprogramDisplayName :: InternString m => MetaPtr -> m ByteString
cMetaSubprogramDisplayName = shareString {#get CMeta->u.metaSubprogramInfo.displayName#}
cMetaSubprogramLinkageName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaSubprogramType = {#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 MetaPtr
cMetaTypeContext = {#get CMeta->u.metaTypeInfo.context#}
cMetaTypeName :: InternString m => MetaPtr -> m ByteString
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
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#}

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 :: ByteString -> m ByteString

-- | This helper converts C char* strings into ByteStrings, 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 ByteString
shareString accessor ptr = do
  sp <- liftIO $ accessor ptr
  when (sp == nullPtr) (error "Null ptr in string")
  str <- liftIO $ BS.packCString sp
  internString str
  {-
  s <- get
  let cache = stringCache s
  case M.lookup str cache of
    Just cval -> return cval
    Nothing -> do
      put s { stringCache = M.insert str str cache }
      return 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 ByteString)
cGlobalSection g = do
  s <- {#get CGlobalInfo->section#} g
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just 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 ByteString)
cFunctionSection f = do
  s <- {#get CFunctionInfo->section#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just 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 ByteString)
cFunctionGCName f = do
  s <- {#get CFunctionInfo->gcName#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just 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 ByteString
cInlineAsmString a =
  ({#get CInlineAsmInfo->asmString#} a) >>= BS.packCString
cInlineAsmConstraints :: InlineAsmInfoPtr -> IO ByteString
cInlineAsmConstraints a =
  ({#get CInlineAsmInfo->constraintString#} a) >>= BS.packCString

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)

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#}

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

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

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

import Control.Applicative
import Control.Monad ( when )
import Control.Monad.Trans ( MonadIO, liftIO )
import Data.Array.Storable
import Data.ByteString.Char8 ( ByteString )
import qualified Data.ByteString.Char8 as BS
import Data.Int
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable

import Data.LLVM.Attributes
import Data.LLVM.Dwarf
import Data.LLVM.Identifiers

#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 #}

cModuleIdentifier :: ModulePtr -> IO ByteString
cModuleIdentifier m = ({#get CModule->moduleIdentifier#} m) >>= BS.packCString

cModuleDataLayout :: ModulePtr -> IO ByteString
cModuleDataLayout m = ({#get CModule->moduleDataLayout#} m) >>= BS.packCString

cModuleTargetTriple :: ModulePtr -> IO ByteString
cModuleTargetTriple m = ({#get CModule->targetTriple#} m) >>= BS.packCString

cModuleInlineAsm :: ModulePtr -> IO ByteString
cModuleInlineAsm m = ({#get CModule->moduleInlineAsm#} m) >>= BS.packCString

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#})

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)
      arr <- unsafeForeignPtrToStorableArray fArrPtr (1, fromIntegral nElts)
      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 String
cTypeName t = {#get CType->name#} t >>= peekCString
cTypeAddrSpace :: TypePtr -> IO Int
cTypeAddrSpace t = fromIntegral <$> {#get CType->addrSpace#} t

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

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

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

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

cMetaTag :: MetaPtr -> IO DW_TAG
cMetaTag p = dw_tag <$> {#get CMeta->tag#} p

cMetaArrayElts :: MetaPtr -> IO [MetaPtr]
cMetaArrayElts p =
  peekArray p {#get CMeta->u.metaArrayInfo.arrayElts#} {#get CMeta->u.metaArrayInfo.arrayLen#}
cMetaEnumeratorName :: InternString m => MetaPtr -> m ByteString
cMetaEnumeratorName = shareString {#get CMeta->u.metaEnumeratorInfo.enumName#}
cMetaEnumeratorValue :: MetaPtr -> IO Int64
cMetaEnumeratorValue p = fromIntegral <$> {#get CMeta->u.metaEnumeratorInfo.enumValue#} p
cMetaGlobalContext :: MetaPtr -> IO MetaPtr
cMetaGlobalContext = {#get CMeta->u.metaGlobalInfo.context #}
cMetaGlobalName :: InternString m => MetaPtr -> m ByteString
cMetaGlobalName = shareString {#get CMeta->u.metaGlobalInfo.name#}
cMetaGlobalDisplayName :: InternString m => MetaPtr -> m ByteString
cMetaGlobalDisplayName = shareString {#get CMeta->u.metaGlobalInfo.displayName#}
cMetaGlobalLinkageName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaGlobalType = {#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 MetaPtr
cMetaLocationScope = {#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 MetaPtr
cMetaTemplateTypeContext = {#get CMeta->u.metaTemplateTypeInfo.context#}
cMetaTemplateTypeName :: InternString m => MetaPtr -> m ByteString
cMetaTemplateTypeName = shareString {#get CMeta->u.metaTemplateTypeInfo.name#}
cMetaTemplateTypeType :: MetaPtr -> IO MetaPtr
cMetaTemplateTypeType = {#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 MetaPtr
cMetaTemplateValueContext = {#get CMeta->u.metaTemplateValueInfo.context#}
cMetaTemplateValueName :: InternString m => MetaPtr -> m ByteString
cMetaTemplateValueName = shareString {#get CMeta->u.metaTemplateValueInfo.name#}
cMetaTemplateValueType :: MetaPtr -> IO MetaPtr
cMetaTemplateValueType = {#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 MetaPtr
cMetaVariableContext = {#get CMeta->u.metaVariableInfo.context#}
cMetaVariableName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaVariableType = {#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 ByteString
cMetaCompileUnitFilename = shareString {#get CMeta->u.metaCompileUnitInfo.filename#}
cMetaCompileUnitDirectory :: InternString m => MetaPtr -> m ByteString
cMetaCompileUnitDirectory = shareString {#get CMeta->u.metaCompileUnitInfo.directory#}
cMetaCompileUnitProducer :: InternString m => MetaPtr -> m ByteString
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 ByteString
cMetaCompileUnitFlags = shareString {#get CMeta->u.metaCompileUnitInfo.flags#}
cMetaCompileUnitRuntimeVersion :: MetaPtr -> IO Int32
cMetaCompileUnitRuntimeVersion p = fromIntegral <$> {#get CMeta->u.metaCompileUnitInfo.runtimeVersion#} p
cMetaFileFilename :: InternString m => MetaPtr -> m ByteString
cMetaFileFilename = shareString {#get CMeta->u.metaFileInfo.filename#}
cMetaFileDirectory :: InternString m => MetaPtr -> m ByteString
cMetaFileDirectory = shareString {#get CMeta->u.metaFileInfo.directory#}
cMetaFileCompileUnit :: MetaPtr -> IO MetaPtr
cMetaFileCompileUnit = {#get CMeta->u.metaFileInfo.compileUnit#}
cMetaLexicalBlockContext :: MetaPtr -> IO MetaPtr
cMetaLexicalBlockContext = {#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 MetaPtr
cMetaNamespaceContext = {#get CMeta->u.metaNamespaceInfo.context#}
cMetaNamespaceName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaSubprogramContext = {#get CMeta->u.metaSubprogramInfo.context#}
cMetaSubprogramName :: InternString m => MetaPtr -> m ByteString
cMetaSubprogramName = shareString {#get CMeta->u.metaSubprogramInfo.name#}
cMetaSubprogramDisplayName :: InternString m => MetaPtr -> m ByteString
cMetaSubprogramDisplayName = shareString {#get CMeta->u.metaSubprogramInfo.displayName#}
cMetaSubprogramLinkageName :: InternString m => MetaPtr -> m ByteString
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 MetaPtr
cMetaSubprogramType = {#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 MetaPtr
cMetaTypeContext = {#get CMeta->u.metaTypeInfo.context#}
cMetaTypeName :: InternString m => MetaPtr -> m ByteString
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
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#}

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 :: ByteString -> m ByteString

-- | This helper converts C char* strings into ByteStrings, 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 ByteString
shareString accessor ptr = do
  sp <- liftIO $ accessor ptr
  when (sp == nullPtr) (error "Null ptr in string")
  str <- liftIO $ BS.packCString sp
  internString str
  {-
  s <- get
  let cache = stringCache s
  case M.lookup str cache of
    Just cval -> return cval
    Nothing -> do
      put s { stringCache = M.insert str str cache }
      return 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 ByteString)
cGlobalSection g = do
  s <- {#get CGlobalInfo->section#} g
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just 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 ByteString)
cFunctionSection f = do
  s <- {#get CFunctionInfo->section#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just 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 ByteString)
cFunctionGCName f = do
  s <- {#get CFunctionInfo->gcName#} f
  case s == nullPtr of
    True -> return Nothing
    False -> do
      bs <- BS.packCString s
      return $! Just 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 ByteString
cInlineAsmString a =
  ({#get CInlineAsmInfo->asmString#} a) >>= BS.packCString
cInlineAsmConstraints :: InlineAsmInfoPtr -> IO ByteString
cInlineAsmConstraints a =
  ({#get CInlineAsmInfo->constraintString#} a) >>= BS.packCString

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)

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#}

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

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


[project @ 2005-10-30 11:56:30 by as49] Fix wrong link.

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Types
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Haskell bindings to the cairo types.
-----------------------------------------------------------------------------

-- #hide
module Graphics.Rendering.Cairo.Types (
    Matrix(Matrix), MatrixPtr
  , Cairo(Cairo), unCairo
  , Surface(Surface), unSurface
  , Pattern(Pattern), unPattern
  , Status(..)
  , Operator(..)
  , Antialias(..)
  , FillRule(..)
  , LineCap(..)
  , LineJoin(..)
  , ScaledFont(..), unScaledFont
  , FontFace(..), unFontFace
  , Glyph, unGlyph
  , TextExtentsPtr
  , TextExtents(..)
  , FontExtentsPtr
  , FontExtents(..)
  , FontSlant(..)
  , FontWeight(..)
  , SubpixelOrder(..)
  , HintStyle(..)
  , HintMetrics(..)
  , FontOptions(..), withFontOptions, mkFontOptions
  , Path(..), unPath
  , Content(..)
  , Format(..)
  , Extend(..)
  , Filter(..)

  , cIntConv
  , cFloatConv
  , cFromBool
  , cToBool
  , cToEnum
  , cFromEnum
  , peekFloatConv
  , withFloatConv

  ) where

{#import Graphics.Rendering.Cairo.Matrix#}

import Foreign hiding (rotate)
import CForeign

import Monad (liftM)

{#context lib="cairo" prefix="cairo"#}

-- not visible
{#pointer *cairo_t as Cairo newtype#}
unCairo (Cairo x) = x

-- | The medium to draw on.
{#pointer *surface_t as Surface newtype#}
unSurface (Surface x) = x

-- | Attributes for drawing operations.
{#pointer *pattern_t as Pattern newtype#}
unPattern (Pattern x) = x

-- | Cairo status.
--
-- * 'Status' is used to indicate errors that can occur when using
--   Cairo. In some cases it is returned directly by functions. When using
--   'Graphics.Rendering.Cairo.Render', the last error, if any, is stored
--   in the monad and can be retrieved with 'Graphics.Rendering.Cairo.status'.
--
{#enum status_t as Status {underscoreToCase} deriving(Eq)#}

-- | Composition operator for all drawing operations.
--
{#enum operator_t as Operator {underscoreToCase}#}

-- | Specifies the type of antialiasing to do when rendering text or shapes
--
-- ['AntialiasDefault']  Use the default antialiasing for the subsystem
-- and target device.
--
-- ['AntialiasNone']  Use a bilevel alpha mask.
--
-- ['AntialiasGray']  Perform single-color antialiasing (using shades of
-- gray for black text on a white background, for example).
--
-- ['AntialiasSubpixel']  Perform antialiasing by taking advantage of
-- the order of subpixel elements on devices such as LCD panels.
--
{#enum antialias_t as Antialias {underscoreToCase}#}

-- | Specify how paths are filled.
--
-- * For both fill rules, whether or not a point is included in the fill is
--   determined by taking a ray from that point to infinity and looking at
--   intersections with the path. The ray can be in any direction, as long
--   as it doesn't pass through the end point of a segment or have a tricky
--   intersection such as intersecting tangent to the path. (Note that
--   filling is not actually implemented in this way. This is just a
--   description of the rule that is applied.)
--
-- ['FillRuleWinding']  If the path crosses the ray from left-to-right,
--   counts +1. If the path crosses the ray from right to left, counts -1.
--   (Left and right are determined from the perspective of looking along
--   the ray from the starting point.) If the total count is non-zero, the
--   point will be filled.
--
-- ['FillRuleEvenOdd']  Counts the total number of intersections,
--   without regard to the orientation of the contour. If the total number
--   of intersections is odd, the point will be filled.
--
{#enum fill_rule_t as FillRule {underscoreToCase}#}

-- | Specify line endings.
--
-- ['LineCapButt'] Start(stop) the line exactly at the start(end) point.
--
-- ['LineCapRound'] Use a round ending, the center of the circle is the
--   end point.
--
-- ['LineCapSquare'] Use squared ending, the center of the square is the
--   end point
--
{#enum line_cap_t as LineCap {underscoreToCase}#}

-- | Specify how lines join.
--
{#enum line_join_t as LineJoin {underscoreToCase}#}

{#pointer *scaled_font_t as ScaledFont newtype#}
unScaledFont (ScaledFont x) = x

{#pointer *font_face_t as FontFace newtype#}
unFontFace (FontFace x) = x

{#pointer *glyph_t as Glyph newtype#}
unGlyph (Glyph x) = x

{#pointer *text_extents_t as TextExtentsPtr -> TextExtents#}

-- | Specify the extents of a text.
data TextExtents = TextExtents {
    textExtentsXbearing :: Double
  , textExtentsYbearing :: Double
  , textExtentsWidth    :: Double
  , textExtentsHeight   :: Double
  , textExtentsXadvance :: Double
  , textExtentsYadvance :: Double
  }

instance Storable TextExtents where
  sizeOf _ = {#sizeof text_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    x_bearing <- {#get text_extents_t->x_bearing#} p
    y_bearing <- {#get text_extents_t->y_bearing#} p
    width     <- {#get text_extents_t->width#}     p
    height    <- {#get text_extents_t->height#}    p
    x_advance <- {#get text_extents_t->x_advance#} p
    y_advance <- {#get text_extents_t->y_advance#} p
    return $ TextExtents (cFloatConv x_bearing) (cFloatConv y_bearing)
                         (cFloatConv width)     (cFloatConv height)
                         (cFloatConv x_advance) (cFloatConv y_advance)
  poke p (TextExtents x_bearing y_bearing width height x_advance y_advance) = do
    {#set text_extents_t->x_bearing#} p (cFloatConv x_bearing)
    {#set text_extents_t->y_bearing#} p (cFloatConv y_bearing)
    {#set text_extents_t->width#}     p (cFloatConv width)
    {#set text_extents_t->height#}    p (cFloatConv height)
    {#set text_extents_t->x_advance#} p (cFloatConv x_advance)
    {#set text_extents_t->y_advance#} p (cFloatConv y_advance)
    return ()

{#pointer *font_extents_t as FontExtentsPtr -> FontExtents#}

-- | Result of querying the font extents.
data FontExtents = FontExtents {
    fontExtentsAscent      :: Double
  , fontExtentsDescent     :: Double
  , fontExtentsHeight      :: Double
  , fontExtentsMaxXadvance :: Double
  , fontExtentsMaxYadvance :: Double
  }

instance Storable FontExtents where
  sizeOf _ = {#sizeof font_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    ascent        <- {#get font_extents_t->ascent#}        p
    descent       <- {#get font_extents_t->descent#}       p
    height        <- {#get font_extents_t->height#}        p
    max_x_advance <- {#get font_extents_t->max_x_advance#} p
    max_y_advance <- {#get font_extents_t->max_y_advance#} p
    return $ FontExtents (cFloatConv ascent) (cFloatConv descent) (cFloatConv height)
                         (cFloatConv max_x_advance) (cFloatConv max_y_advance)
  poke p (FontExtents ascent descent height max_x_advance max_y_advance) = do
    {#set font_extents_t->ascent#}        p (cFloatConv ascent)
    {#set font_extents_t->descent#}       p (cFloatConv descent)
    {#set font_extents_t->height#}        p (cFloatConv height)
    {#set font_extents_t->max_x_advance#} p (cFloatConv max_x_advance)
    {#set font_extents_t->max_y_advance#} p (cFloatConv max_y_advance)
    return ()

-- | Specify font slant.
{#enum font_slant_t as FontSlant {underscoreToCase}#}

-- | Specify font weight.
{#enum font_weight_t as FontWeight {underscoreToCase}#}

-- | Specify subpixel order.
{#enum subpixel_order_t as SubpixelOrder {underscoreToCase}#}

-- | FIXME: Document.
{#enum hint_style_t as HintStyle {underscoreToCase}#}

-- | FIXME: Document.
{#enum hint_metrics_t as HintMetrics {underscoreToCase}#}

-- | Specifies how to render text.
{#pointer *font_options_t as FontOptions foreign newtype#}

withFontOptions (FontOptions fptr) = withForeignPtr fptr

mkFontOptions :: Ptr FontOptions -> IO FontOptions
mkFontOptions fontOptionsPtr = do
  fontOptionsForeignPtr <- newForeignPtr fontOptionsDestroy fontOptionsPtr
  return (FontOptions fontOptionsForeignPtr)

foreign import ccall unsafe "&cairo_font_options_destroy"
  fontOptionsDestroy :: FinalizerPtr FontOptions

-- XXX: pathToList :: Path -> [PathData]
--
-- http://cairographics.org/manual/bindings-path.html
--
-- {#enum path_data_type_t as PathDataType {underscoreToCase}#}
--
-- type Point = (Double, Double)
-- data PathData = PathMoveTo Point
--               | PathLineTo Point
--               | PathCurveTo Point Point Point
--               | PathClose

-- | A Cairo path.
--
-- * A path is a sequence of drawing operations that are accumulated until
--   'Graphics.Rendering.Cairo.stroke' is called. Using a path is particularly
--   useful when drawing lines with special join styles and
--   'Graphics.Rendering.Cairo.closePath'.
--
{#pointer *path_t as Path newtype#}
unPath (Path x) = x

{#enum content_t as Content {underscoreToCase}#}

data Format = FormatARGB32
            | FormatRGB24
            | FormatA8
            | FormatA1
            deriving (Enum)

-- | FIX ME: We should find out about this.
{#enum extend_t as Extend {underscoreToCase}#}

-- | Specify how filtering is done.
{#enum filter_t as Filter {underscoreToCase}#}

-- Marshalling functions

cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral

cFloatConv :: (RealFloat a, RealFloat b) => a -> b
cFloatConv  = realToFrac

cFromBool :: Num a => Bool -> a
cFromBool  = fromBool

cToBool :: Num a => a -> Bool
cToBool  = toBool

cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . cIntConv

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = cIntConv . fromEnum

peekFloatConv :: (Storable a, RealFloat a, RealFloat b) =>  Ptr a -> IO b
peekFloatConv  = liftM cFloatConv . peek

withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c
withFloatConv  = with . cFloatConv

withArrayFloatConv :: (Storable b, RealFloat a, RealFloat b) => [a] -> (Ptr b -> IO b1) -> IO b1
withArrayFloatConv = withArray . map (cFloatConv)

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Types
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Haskell bindings to the cairo types.
-----------------------------------------------------------------------------

-- #hide
module Graphics.Rendering.Cairo.Types (
    Matrix(Matrix), MatrixPtr
  , Cairo(Cairo), unCairo
  , Surface(Surface), unSurface
  , Pattern(Pattern), unPattern
  , Status(..)
  , Operator(..)
  , Antialias(..)
  , FillRule(..)
  , LineCap(..)
  , LineJoin(..)
  , ScaledFont(..), unScaledFont
  , FontFace(..), unFontFace
  , Glyph, unGlyph
  , TextExtentsPtr
  , TextExtents(..)
  , FontExtentsPtr
  , FontExtents(..)
  , FontSlant(..)
  , FontWeight(..)
  , SubpixelOrder(..)
  , HintStyle(..)
  , HintMetrics(..)
  , FontOptions(..), withFontOptions, mkFontOptions
  , Path(..), unPath
  , Content(..)
  , Format(..)
  , Extend(..)
  , Filter(..)

  , cIntConv
  , cFloatConv
  , cFromBool
  , cToBool
  , cToEnum
  , cFromEnum
  , peekFloatConv
  , withFloatConv

  ) where

{#import Graphics.Rendering.Cairo.Matrix#}

import Foreign hiding (rotate)
import CForeign

import Monad (liftM)

{#context lib="cairo" prefix="cairo"#}

-- not visible
{#pointer *cairo_t as Cairo newtype#}
unCairo (Cairo x) = x

-- | The medium to draw on.
{#pointer *surface_t as Surface newtype#}
unSurface (Surface x) = x

-- | Attributes for drawing operations.
{#pointer *pattern_t as Pattern newtype#}
unPattern (Pattern x) = x

-- | Cairo status.
--
-- * 'Status' is used to indicate errors that can occur when using
--   Cairo. In some cases it is returned directly by functions. When using
--   'Graphics.Rendering.Cairo.Render', the last error, if any, is stored
--   in the monad and can be retrieved with 'Graphics.Rendering.Cairo.status'.
--
{#enum status_t as Status {underscoreToCase} deriving(Eq)#}

-- | Composition operator for all drawing operations.
--
{#enum operator_t as Operator {underscoreToCase}#}

-- | Specifies the type of antialiasing to do when rendering text or shapes
--
-- ['AntialiasDefault']  Use the default antialiasing for the subsystem
-- and target device.
--
-- ['AntialiasNone']  Use a bilevel alpha mask.
--
-- ['AntialiasGray']  Perform single-color antialiasing (using shades of
-- gray for black text on a white background, for example).
--
-- ['AntialiasSubpixel']  Perform antialiasing by taking advantage of
-- the order of subpixel elements on devices such as LCD panels.
--
{#enum antialias_t as Antialias {underscoreToCase}#}

-- | Specify how paths are filled.
--
-- * For both fill rules, whether or not a point is included in the fill is
--   determined by taking a ray from that point to infinity and looking at
--   intersections with the path. The ray can be in any direction, as long
--   as it doesn't pass through the end point of a segment or have a tricky
--   intersection such as intersecting tangent to the path. (Note that
--   filling is not actually implemented in this way. This is just a
--   description of the rule that is applied.)
--
-- ['FillRuleWinding']  If the path crosses the ray from left-to-right,
--   counts +1. If the path crosses the ray from right to left, counts -1.
--   (Left and right are determined from the perspective of looking along
--   the ray from the starting point.) If the total count is non-zero, the
--   point will be filled.
--
-- ['FillRuleEvenOdd']  Counts the total number of intersections,
--   without regard to the orientation of the contour. If the total number
--   of intersections is odd, the point will be filled.
--
{#enum fill_rule_t as FillRule {underscoreToCase}#}

-- | Specify line endings.
--
-- ['LineCapButt'] Start(stop) the line exactly at the start(end) point.
--
-- ['LineCapRound'] Use a round ending, the center of the circle is the
--   end point.
--
-- ['LineCapSquare'] Use squared ending, the center of the square is the
--   end point
--
{#enum line_cap_t as LineCap {underscoreToCase}#}

-- | Specify how lines join.
--
{#enum line_join_t as LineJoin {underscoreToCase}#}

{#pointer *scaled_font_t as ScaledFont newtype#}
unScaledFont (ScaledFont x) = x

{#pointer *font_face_t as FontFace newtype#}
unFontFace (FontFace x) = x

{#pointer *glyph_t as Glyph newtype#}
unGlyph (Glyph x) = x

{#pointer *text_extents_t as TextExtentsPtr -> TextExtents#}

-- | Specify the extents of a text.
data TextExtents = TextExtents {
    textExtentsXbearing :: Double
  , textExtentsYbearing :: Double
  , textExtentsWidth    :: Double
  , textExtentsHeight   :: Double
  , textExtentsXadvance :: Double
  , textExtentsYadvance :: Double
  }

instance Storable TextExtents where
  sizeOf _ = {#sizeof text_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    x_bearing <- {#get text_extents_t->x_bearing#} p
    y_bearing <- {#get text_extents_t->y_bearing#} p
    width     <- {#get text_extents_t->width#}     p
    height    <- {#get text_extents_t->height#}    p
    x_advance <- {#get text_extents_t->x_advance#} p
    y_advance <- {#get text_extents_t->y_advance#} p
    return $ TextExtents (cFloatConv x_bearing) (cFloatConv y_bearing)
                         (cFloatConv width)     (cFloatConv height)
                         (cFloatConv x_advance) (cFloatConv y_advance)
  poke p (TextExtents x_bearing y_bearing width height x_advance y_advance) = do
    {#set text_extents_t->x_bearing#} p (cFloatConv x_bearing)
    {#set text_extents_t->y_bearing#} p (cFloatConv y_bearing)
    {#set text_extents_t->width#}     p (cFloatConv width)
    {#set text_extents_t->height#}    p (cFloatConv height)
    {#set text_extents_t->x_advance#} p (cFloatConv x_advance)
    {#set text_extents_t->y_advance#} p (cFloatConv y_advance)
    return ()

{#pointer *font_extents_t as FontExtentsPtr -> FontExtents#}

-- | Result of querying the font extents.
data FontExtents = FontExtents {
    fontExtentsAscent      :: Double
  , fontExtentsDescent     :: Double
  , fontExtentsHeight      :: Double
  , fontExtentsMaxXadvance :: Double
  , fontExtentsMaxYadvance :: Double
  }

instance Storable FontExtents where
  sizeOf _ = {#sizeof font_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    ascent        <- {#get font_extents_t->ascent#}        p
    descent       <- {#get font_extents_t->descent#}       p
    height        <- {#get font_extents_t->height#}        p
    max_x_advance <- {#get font_extents_t->max_x_advance#} p
    max_y_advance <- {#get font_extents_t->max_y_advance#} p
    return $ FontExtents (cFloatConv ascent) (cFloatConv descent) (cFloatConv height)
                         (cFloatConv max_x_advance) (cFloatConv max_y_advance)
  poke p (FontExtents ascent descent height max_x_advance max_y_advance) = do
    {#set font_extents_t->ascent#}        p (cFloatConv ascent)
    {#set font_extents_t->descent#}       p (cFloatConv descent)
    {#set font_extents_t->height#}        p (cFloatConv height)
    {#set font_extents_t->max_x_advance#} p (cFloatConv max_x_advance)
    {#set font_extents_t->max_y_advance#} p (cFloatConv max_y_advance)
    return ()

-- | Specify font slant.
{#enum font_slant_t as FontSlant {underscoreToCase}#}

-- | Specify font weight.
{#enum font_weight_t as FontWeight {underscoreToCase}#}

-- | Specify subpixel order.
{#enum subpixel_order_t as SubpixelOrder {underscoreToCase}#}

-- | FIXME: Document.
{#enum hint_style_t as HintStyle {underscoreToCase}#}

-- | FIXME: Document.
{#enum hint_metrics_t as HintMetrics {underscoreToCase}#}

-- | Specifies how to render text.
{#pointer *font_options_t as FontOptions foreign newtype#}

withFontOptions (FontOptions fptr) = withForeignPtr fptr

mkFontOptions :: Ptr FontOptions -> IO FontOptions
mkFontOptions fontOptionsPtr = do
  fontOptionsForeignPtr <- newForeignPtr fontOptionsDestroy fontOptionsPtr
  return (FontOptions fontOptionsForeignPtr)

foreign import ccall unsafe "&cairo_font_options_destroy"
  fontOptionsDestroy :: FinalizerPtr FontOptions

-- XXX: pathToList :: Path -> [PathData]
--
-- http://cairographics.org/manual/bindings-path.html
--
-- {#enum path_data_type_t as PathDataType {underscoreToCase}#}
--
-- type Point = (Double, Double)
-- data PathData = PathMoveTo Point
--               | PathLineTo Point
--               | PathCurveTo Point Point Point
--               | PathClose

-- | A Cairo path.
--
-- * A path is a sequence of drawing operations that are accumulated until
--   'Graphics.Render.Cairo.stroke' is called. Using a path is particularly
--   useful when drawing lines with special join styles and
--   'Graphics.Render.Cairo.closePath'.
--
{#pointer *path_t as Path newtype#}
unPath (Path x) = x

{#enum content_t as Content {underscoreToCase}#}

data Format = FormatARGB32
            | FormatRGB24
            | FormatA8
            | FormatA1
            deriving (Enum)

-- | FIX ME: We should find out about this.
{#enum extend_t as Extend {underscoreToCase}#}

-- | Specify how filtering is done.
{#enum filter_t as Filter {underscoreToCase}#}

-- Marshalling functions

cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral

cFloatConv :: (RealFloat a, RealFloat b) => a -> b
cFloatConv  = realToFrac

cFromBool :: Num a => Bool -> a
cFromBool  = fromBool

cToBool :: Num a => a -> Bool
cToBool  = toBool

cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . cIntConv

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = cIntConv . fromEnum

peekFloatConv :: (Storable a, RealFloat a, RealFloat b) =>  Ptr a -> IO b
peekFloatConv  = liftM cFloatConv . peek

withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c
withFloatConv  = with . cFloatConv

withArrayFloatConv :: (Storable b, RealFloat a, RealFloat b) => [a] -> (Ptr b -> IO b1) -> IO b1
withArrayFloatConv = withArray . map (cFloatConv)