HaskellでDirect3D11を使う

最初に断っておくとインチキです。(笑)
純粋にHaskellでCOMインタフェイスを叩いてるわけではないので期待された方すいません。
ポイントはこれだけです。

• Direct3D11インタフェイスはC++で叩いてDLL化する
• Haskellは自分で作ったDLLを呼び出す

C++側の実装

D3D11のチュートリアルから大半をコピペ。
グローバルに置いてあった変数だけ構造体にまとめて、その構造体のポインタだけを呼び出し側に返せるようにします。
これはデータ型の抽象化にも繋がっています。

#include "stdafx.h"

struct MNContext
{
    ID3D11Device* pDevice;
    IDXGISwapChain* pSwapChain;
    ID3D11DeviceContext* pImmediateContext;
    ID3D11RenderTargetView* pRenderTargetView;
};

extern "C" HRESULT MNCreateContext( HWND hwnd, MNContext** ppOut )
{
    MNContext* pContext = new MNContext;

    HRESULT hr;

    uint32_t width = 640;
    uint32_t height = 480;

    // デバイスとスワップチェインを構築
    UINT createDeviceFlags = 0;

    D3D_DRIVER_TYPE driverTypes[] =
    {
        D3D_DRIVER_TYPE_HARDWARE,
        D3D_DRIVER_TYPE_WARP,
        D3D_DRIVER_TYPE_REFERENCE,
    };
    UINT numDriverTypes = ARRAYSIZE( driverTypes );

    D3D_FEATURE_LEVEL featureLevels[] =
    {
        D3D_FEATURE_LEVEL_11_0,
        D3D_FEATURE_LEVEL_10_1,
        D3D_FEATURE_LEVEL_10_0,
    };
    UINT numFeatureLevels = ARRAYSIZE( featureLevels );

    DXGI_SWAP_CHAIN_DESC sd;
    ZeroMemory( &sd, sizeof( sd ) );
    sd.BufferCount = 1;
    sd.BufferDesc.Width = width;
    sd.BufferDesc.Height = height;
    sd.BufferDesc.Format = DXGI_FORMAT_R8G8B8A8_UNORM;
    sd.BufferDesc.RefreshRate.Numerator = 60;
    sd.BufferDesc.RefreshRate.Denominator = 1;
    sd.BufferUsage = DXGI_USAGE_RENDER_TARGET_OUTPUT;
    sd.OutputWindow = hwnd;
    sd.SampleDesc.Count = 1;
    sd.SampleDesc.Quality = 0;
    sd.Windowed = TRUE;

    D3D_FEATURE_LEVEL featureLevel;

    for( UINT driverTypeIndex = 0; driverTypeIndex < numDriverTypes; driverTypeIndex++ )
    {
        hr = D3D11CreateDeviceAndSwapChain(
			NULL,
			driverTypes[driverTypeIndex],
			NULL,
			createDeviceFlags,
			featureLevels,
			numFeatureLevels,
			D3D11_SDK_VERSION,
			&sd,
			&pContext->pSwapChain,
			&pContext->pDevice,
			&featureLevel,
			&pContext->pImmediateContext
			);
        if( SUCCEEDED( hr ) )
            break;
    }
    if( FAILED( hr ) )
        return hr;

    // レンダーターゲットビューを構築
    ID3D11Texture2D* pBackBuffer = NULL;
    hr = pContext->pSwapChain->GetBuffer( 0, __uuidof( ID3D11Texture2D ), ( LPVOID* )&pBackBuffer );
    if( FAILED( hr ) )
    {
        return hr;
    }

    hr = pContext->pDevice->CreateRenderTargetView( pBackBuffer, NULL, &pContext->pRenderTargetView );
    pBackBuffer->Release();
    if( FAILED( hr ) )
    {
        return hr;
    }

    pContext->pImmediateContext->OMSetRenderTargets( 1, &pContext->pRenderTargetView, NULL );

    // ビューポートを設定
    D3D11_VIEWPORT vp;
    vp.Width = (FLOAT)width;
    vp.Height = (FLOAT)height;
    vp.MinDepth = 0.0f;
    vp.MaxDepth = 1.0f;
    vp.TopLeftX = 0;
    vp.TopLeftY = 0;
    pContext->pImmediateContext->RSSetViewports( 1, &vp );

    *ppOut = pContext;
    return S_OK; 
}

extern "C" void MNDeleteContext( MNContext* pContext )
{
    assert( pContext != nullptr );

    pContext->pImmediateContext->ClearState();

    pContext->pRenderTargetView->Release();
    pContext->pImmediateContext->Release();
    pContext->pDevice->Release();
    pContext->pSwapChain->Release();
    delete pContext;
}

extern "C" void MNPresent( MNContext* pContext )
{
    float ClearColor[4] = { 0.0f, 0.125f, 0.3f, 1.0f };
    pContext->pImmediateContext->ClearRenderTargetView( pContext->pRenderTargetView, ClearColor );
    pContext->pSwapChain->Present( 0, 0 );
}

Haskell側のFFIの実装

{-# LANGUAGE ForeignFunctionInterface #-}

module Renderer where

import Graphics.Win32
import System.Win32.Types
import Foreign.Storable
import Foreign.Ptr
import Foreign.Marshal

foreign import ccall "MNCreateContext" c_MNCreateContext :: HWND -> Ptr Addr -> IO HRESULT
foreign import ccall "MNDeleteContext" c_MNDeleteContext :: Addr -> IO ()
foreign import ccall "MNPresent" c_MNPresent :: Addr -> IO ()

mnCreateContext :: HWND -> IO (Addr, HRESULT)
mnCreateContext hwnd = alloca receiver
  where
    receiver :: Ptr Addr -> IO (Addr, HRESULT)
    receiver px = do
      hr <- c_MNCreateContext hwnd px
      x <- peek px
      return (x,hr)

Haskell側のメインループ

onIdle :: Addr -> IO ()
onIdle pContext = c_MNPresent pContext >> sleep 1

pump :: Addr -> LPMSG -> IO ()
pump pContext lpmsg = do
  ret <- c_PeekMessage lpmsg (maybePtr Nothing) 0 0 pM_REMOVE
  case ret of
    -1        -> putStrLn "error"
    0         -> onIdle pContext >> pump pContext lpmsg
    otherwise -> do msg <- peek $ castPtr lpmsg
                    when (msg_message msg /= wM_QUIT) $ do
                      translateMessage lpmsg
                      dispatchMessage lpmsg
                      pump pContext lpmsg

main :: IO ()
main = do
    registerMyClass
    hwnd <- createMyWindow
    (pContext,hr) <- mnCreateContext hwnd
    showWindow hwnd sW_SHOWNORMAL
    updateWindow hwnd
    allocaMessage (pump pContext)
    c_MNDeleteContext pContext
    unregisterMyClass

描画結果

てなわけで、HaskellからD3D11を使って画面クリアできました。