sirocco の書いてもすぐに忘れるメモ

Haskellで副作用を起こす(Win32 API によるUTF-16 ⇔ Shift-JIS 変換)

文字コード, MS-Windows, Haskell | 21:01 |

タイトルは釣りです。副作用を起こしているのはHaskellから読んでいるCのライブラリです。

Win32 APIのWideCharToMultiByte、MultiByteToWideCharでUTF-16 ⇔ Shift-JIS 変換を行うには変換結果を格納するバッファを確保してそのポインタを引数に渡し、そのバッファに書き込まれた文字列を使用します。つまり、副作用によって結果を受け取っています。

Haskellで副作用が書けるのでしょうか?　普通に副作用が書けます。

ヌルポ(nullPtr)もあって、へぇ〜って感心してしまいます。

• cstringToBSTR ではcSysAllocStringLenで確保したBSTR用のメモリの先頭アドレスをcMultiByteToWideCharに渡し、開きこまれたそのBSTR用のメモリの先頭アドレスを返しています。
• bstrToCString では mallocBytes でワイド文字列からC文字列に変換したときの長さ分の文字列領域を確保し、その先頭アドレスをcWideCharToMultiByteへ渡します。書き込まれたC文字列領域の先頭アドレスを返しています。

foreign importでCライブラリを型で安全に操作するための定義は値の内容にマッチさせます。それから、Cの関数を呼んだときに辻褄が合うように型を合わせないと　fromIntegralを多用することになってしまいます。

-- ghc --make -Wall utf.hs -loleaut32  -o utf

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

module Main where

import Foreign.Marshal.Alloc
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr

#define CP_ACP 0
-- Shift-JISからUtf16への変換
shiftJisToUtf16 :: String -> IO String
shiftJisToUtf16 string = do
    bstr <- withCString string cstringToBSTR
    str  <- peekCWString bstr
    cSysFreeString bstr
    return str

cstringToBSTR :: CString -> IO (Ptr CWchar)
cstringToBSTR cstring = do
    -- C文字列長(1文字1バイト、2バイト混在)
    cstringlen <- cstrlen cstring
    -- UTF-16(1文字2バイト)の文字列長さを算出
    out_size   <- cMultiByteToWideChar CP_ACP 0 cstring cstringlen nullPtr 0
    -- out_size分のメモリを確保した先頭アドレス
    wstr       <- cSysAllocStringLen nullPtr out_size
    -- C文字列をUTF-16文字列に変換してwstrに書き込まれる。
    _          <- cMultiByteToWideChar CP_ACP 0 cstring cstringlen wstr out_size
    -- 書き込まれたwstrを返す。
    return wstr

utf16ToShiftJis :: String -> IO String
utf16ToShiftJis string = do
    cstring <- withCWString string bstrToCString
    str     <- peekCString cstring
    free cstring
    return str

bstrToCString :: Ptr CWchar -> IO CString
bstrToCString bstr = do
    out_size <- cWideCharToMultiByte CP_ACP 0 bstr (-1) nullPtr 0 nullPtr nullPtr
    -- cstringにメモリを確保
    cstring  <- mallocBytes ((fromIntegral out_size) + 1):: IO (Ptr CChar)
    _        <- cWideCharToMultiByte CP_ACP 0 bstr (-1) cstring out_size nullPtr nullPtr
    -- 書き込まれたcstringを返す。
    return cstring

foreign import stdcall "windows.h SysFreeString" cSysFreeString          :: Ptr CWchar -> IO ()
foreign import stdcall "windows.h SysAllocStringLen" cSysAllocStringLen  :: Ptr CWchar -> CInt -> IO (Ptr CWchar)

-- http://msdn.microsoft.com/ja-jp/library/cc448089.aspx
foreign import stdcall "windows.h WideCharToMultiByte" cWideCharToMultiByte
        :: CUInt      ->  --  UINT CodePage,           // コードページ
           CULong     ->  --  DWORD dwFlags,           // 処理速度とマッピング方法を決定するフラグ
           Ptr CWchar ->  --  LPCWSTR lpWideCharStr,   // ワイド文字列のアドレス
           CInt       ->  --  int cchWideChar,         // ワイド文字列の文字数
           CString    ->  --  LPSTR lpMultiByteStr,    // 新しい文字列を受け取るバッファのアドレス
           CInt       ->  --  int cchMultiByte,        // 新しい文字列を受け取るバッファのサイズ
           CString    ->  --  LPCSTR lpDefaultChar,    // マップできない文字の既定値のアドレス
           Ptr Int    ->  --  LPBOOL lpUsedDefaultChar //既定の文字を使ったときにセットするフラグのアドレス
           IO CInt

-- http://msdn.microsoft.com/ja-jp/library/cc448053.aspx
foreign import stdcall "windows.h MultiByteToWideChar" cMultiByteToWideChar
        :: CUInt      ->  --    UINT CodePage,         // コードページ
           CULong     ->  --    DWORD dwFlags,         // 文字の種類を指定するフラグ
           CString    ->  --    LPCSTR lpMultiByteStr, // マップ元文字列のアドレス
           CInt       ->  --    int cchMultiByte,      // マップ元文字列のバイト数
           Ptr CWchar ->  --    LPWSTR lpWideCharStr,  // マップ先ワイド文字列を入れるバッファのアドレス
           CInt       ->  --    int cchWideChar        // バッファのサイズ
           IO CInt

foreign import ccall "string.h strlen"  cstrlen   :: CString  -> IO CInt
foreign import ccall "stdio.h printf"   cprintf   :: CString  -> IO ()
foreign import ccall "stdio.h printf"   cprint2   :: CString  -> CUInt -> CUInt -> IO ()
foreign import ccall "wchar.h wprintf"  cwprintf  :: CWString -> IO ()
foreign import ccall "wchar.h swprintf" cswprintf :: CWString -> CWString -> IO ()

main :: IO ()
main = do
    s <- utf16ToShiftJis "ﾏｯﾌﾟ先ワイド文字列を入れるバッファのaddress"
    u <- shiftJisToUtf16 s
    putStrLn =<< (utf16ToShiftJis u)

-- PS C:\HaskellPlatform\test\utf8utf16> ./utf
-- > ﾏｯﾌﾟ先ワイド文字列を入れるバッファのaddress

foreign import の ccall、stdcallは関数を呼ぶときの引数の渡し方です。これを書かなくても推測してくれないかと思いましたがリンクのときにWarningになるようです。

$ ghc --make -Wall utf.hs -loleaut32  -o utf
[1 of 1] Compiling Main             ( utf.hs, utf.o )
Linking utf.exe ...
Warning: resolving _MultiByteToWideChar by linking to _MultiByteToWideChar@24
Use --enable-stdcall-fixup to disable these warnings
Use --disable-stdcall-fixup to disable these fixups

こっちは本物の副作用です。

• Foreign.Marshal.Alloc.malloc、Foreign.Storable.peek、pokeを使ってみる。

Foreign.Marshal.Alloc.malloc、Foreign.Storable.peek、pokeを使ってみる。

Haskell | 07:05 |

Win32 APIのMultiByteToWideChar、WideCharToMultiByteを使って UTF-16 ⇔ Shift-JIS 変換する際にCでコード書いた部分があります。

Cで書かないで全部Haskellで書きたいと思うのですが、領域を確保してアドレスを渡し、そのアドレスの中にデータがあるという、いわゆるポインタを通してのデータのやり取りがあります。

ポインタを使ったデータの書き込み、読み取りについて調べてみました。

> :m Foreign.Storable Foreign.Marshal.Alloc

-- malloc の型を表示させてみます。
> :t malloc
malloc :: Storable a => IO (GHC.Ptr.Ptr a)

-- 引数がないのですけれど、そのままmallocを実行するとエラーになります。
> malloc

<interactive>:78:1:
    Ambiguous type variable `a0' in the constraint:
      (Storable a0) arising from a use of `malloc'
    Probable fix: add a type signature that fixes these type variable(s)
    In the expression: malloc
    In an equation for `it': it = malloc

-- add a type signature that fixes these type variable(s) と言って
-- います。
-- ああ、Haskell得意の「出力する型を指定すればその型に応じた値を返す」って
-- やつですね。
> malloc::IO (GHC.Ptr.Ptr Int)      -- >0x04192e10 

> n <- malloc::IO (GHC.Ptr.Ptr Int)  --> Int型のメモリを確保します。

-- poke する前にpokeの型を確認
> :t poke
-- > poke :: Storable a => GHC.Ptr.Ptr a -> a -> IO ()

-- malloc で確保した領域をpokeに渡したときに返す関数の型を確認すると
-- Intを引数とすることが分かります。
> :t poke n
poke n :: Int -> IO ()

-- 7 を書き込んでみます。
> poke n 7
> :t peek n
peek n :: IO Int
-- 書き込んだ値を読んでみます。
> peek n     -- > 7
-- 確保した領域を解放した後はゴミが読みだされました。
> free n
> peek n
31183736

-- 10バイトメモリを確保します。
> m <- mallocBytes 10:: IO (GHC.Ptr.Ptr Int8)
-- 書き込みます
> pokeByteOff m  0 (1::Int8)
> pokeByteOff m  1 (2::Int8)
> pokeByteOff m  2 (3::Int8)

-- 読み出します
> peekByteOff m  0  -- > 2.535e-321
-- あれ？？
-- IO a の a は型変数なので型を指定していすればよさそうです。
> :t (peekByteOff m  0)         -- > peekByteOff m  0 :: Storable a => IO a
>  :t peekByteOff m  0::IO Int8 -- > peekByteOff m  0::IO Int8 :: IO Int8

> peekByteOff m  0::IO Int8 -- > 1
> peekByteOff m  1::IO Int8 -- > 2
> peekByteOff m  2::IO Int8 -- > 3

参考

• HaskellからCライブラリを呼ぶ(FFI)

Win32 API の WideCharToMultiByteを使って UTF-16 ⇔ Shift-JIS 変換する。

文字コード, MS-Windows, Haskell | 11:47 |

UTF-16 ⇔ Shift-JIS の変換は計算によって行うことが出来ません。

そこで Win32 APIのMultiByteToWideChar、WideCharToMultiByteを使って変換します。

• shiftJisToUtf16

Haskell 文字列をWindowsワイド文字列に変換したあとにワイド文字列からpeekCWStringでHaskell文字列を作っています。

そこでその変換した値を返す前にcSysFreeStringでWindowsワイド文字列の領域をクリアするのですが、ふとポインタで指している値が消えると返す値まで消えてしまうのではと心配しました。

Haskell文字列の1文字1文字はヒープにメモリを確保したデータではなくUnboxedな値です。Haskellは常に新しい値を作って返しますから、ポインタが指している値が消えてもHaskell の文字列が消えるなんてないはので開放しても良いはずです。

• utf16ToShiftJis

C で確保したメモリは free で開放しています。

{-# LANGUAGE ForeignFunctionInterface #-}
-- ghc --make -Wall utf8.hs bstr.c -loleaut32 -o utf8

module Main where

import Foreign.Marshal.Alloc 
import Foreign.C.String

shiftJisToUtf16 :: String -> IO String
shiftJisToUtf16 string = do
    bstr <- withCString string c_CStringToBSTR
    str <- peekCWString bstr
    cSysFreeString bstr  -- ※※※※
    return str

utf16ToShiftJis :: String -> IO String
utf16ToShiftJis string = do 
    cstring <- withCWString string c_BSTRtoCString
    str     <- peekCString cstring
    free cstring -- ※※※※
    return str

-- C の関数を呼ぶための定義
foreign import ccall unsafe "CStringToBSTR"      c_CStringToBSTR   :: CString    -> IO CWString
foreign import ccall unsafe "BSTRtoCString"      c_BSTRtoCString   :: CWString   -> IO CString
foreign import stdcall "windows.h SysFreeString"     cSysFreeString      :: CWString -> IO ()

main :: IO ()
main = putStrLn =<< utf16ToShiftJis "こんにちは"

WideChatToMultiByteは2番目の引数にWC_NO_BEST_FIT_CHARSというフラグを指定することができます。指定するとShift_JISの文字が存在しない場合は特定の文字(デフォルトでは '?')に変換されます。指定されていないとよく似た文字に変換されます。

• MultiByteToWideChar
• WideCharToMultiByte
• SysAllocStringLen
• SysFreeString

#include <malloc.h>
#include <windows.h>

BSTR CStringToBSTR(char* cstring ){
    int    cstringlen, out_size;
    BSTR   wstr;
    cstringlen = strlen(cstring);
    // Shift-JIS文字列からUTF-16に変換したときの文字列長を求める。
    out_size   = MultiByteToWideChar(CP_ACP, 0, cstring, cstringlen, NULL, 0);
    // UTF-16文字列の領域を確保する。
    wstr       = SysAllocStringLen(NULL, out_size);
    // Shift-JIS文字列からUTF-16に変換する。
    MultiByteToWideChar(CP_ACP, 0, cstring, cstringlen, wstr, out_size);
    return wstr;
}

char* BSTRtoCString(BSTR bstr){
    int    out_size;
    char   *cstring;
    // UTF-16文字列からShift-JISに変換したときの文字列長を求める。
    out_size = WideCharToMultiByte(CP_ACP, 0, (OLECHAR*)bstr, -1,NULL, 0, NULL, NULL);
    // Shift-JIS文字列の領域を確保する。
    cstring  = (char*)malloc((out_size+1) * sizeof(char));
    // UTF-16文字列からShift-JISに変換する。
    WideCharToMultiByte(CP_ACP, 0, (OLECHAR*)bstr, -1, cstring,out_size, NULL, NULL);
    return cstring;
}

参考

• Gaucheの内部変換アルゴリズムの詳細

出力する値を型を指定することにより変化させる( Use -XTypeSynonymInstances if you want to disable this)

Haskell | 00:40 |

maxBound、minBound は出力する型を指定するをその型が表現できる最大値、最小値を出力します。

> maxBound::Char -->'\1114111'
> maxBound::Int  --> 2147483647
> minBound::Char -->'\NUL'
> minBound::Int  --> -2147483648

これと同じように自分でも出力する型を指定すると動作の変わる関数を定義したくなって以下の型クラスとインスタンスを定義してみました。

returnNum というIntegerを引数とする関数に出力する型を指定して、Integerを返させたり、Stringを返させたりしたい訳です。

class   Rnum  a       where  returnNum :: Integer -> a

instance Rnum Integer where  returnNum n = n

instance Rnum String  where  returnNum n = (show n)

instance Rnum String where returnNum n = (show n)　でエラーになります。

type.hs:7:10:
    Illegal instance declaration for `Rnum String'
      (All instance types must be of the form (T t1 ... tn)
       where T is not a synonym.
       Use -XTypeSynonymInstances if you want to disable this.)
    In the instance declaration for `Rnum String'
Failed, modules loaded: none.

コンパイラのオプションに -XTypeSynonymInstancesをつけろということらしいので。{-# LANGUAGE TypeSynonymInstances #-}を指定するとOKでした。

{-# LANGUAGE TypeSynonymInstances #-}

class   Rnum  a       where  returnNum :: Integer -> a

instance Rnum Integer where  returnNum n = n

instance Rnum String  where  returnNum n = (show n)

{-
> :r
Ok, modules loaded: Main.
-- これで出力をIntegerを指定するとIntegerが返り、Stringを指定するとStringが返ります。
> returnNum 99 :: Integer -- > 99
> returnNum 99 :: String  -- > "99"

-- 同じ関数の結果でも、文脈から判断して働きます。
> 101   +   returnNum 99    -- > 200
> "101" ++  returnNum 99 -- > "10199"
-}

文脈とは何か：文の脈絡。コンテクスト。 文章の流れの中にある意味内容のつながりぐあい。（kotobank > 文脈とは）

• Why can I not make String an instance of a typeclass?

この他に stackoverflow には -XFlexibleInstancesオプションんを指定する方法も紹介されています。

{-# LANGUAGE FlexibleInstances #-}

newtype Wrapper = Wrapper String deriving Show

class   Rnum  a       where  returnNum :: Integer -> a

instance Rnum Integer where  returnNum n = n

instance Rnum Wrapper where returnNum n = Wrapper (show n)

{-
 :r
[1 of 1] Compiling Main             ( type.hs, interpreted )
Ok, modules loaded: Main.
> returnNum 99 :: Integer -- > 99
> returnNum 99 :: Wrapper -- > Wrapper "99"
-}

• 栄光のグラスゴーHaskellコンパイルシステム利用の手引き
  • 7.6.3.1. インスタンス頭部に関する規則の緩和

「実装して理解する遅延評価の仕組み 〜 thunkを絵に描いて理解しよう」をRubyで

Haskell, Ruby | 17:20 |

実装して理解する遅延評価の仕組み 〜 thunkを絵に描いて理解しよう・JavaScriptでHaskellを実装!?をRubyで写経してみます。

• Thunk、 Lambda、App、Evaluateクラスは instance_of? により型を調べるためのものです。
• Thunk でくるんである以外は lambda から取り出すだけ。

class Thunk
  attr_accessor :value
  def initialize(value)
    @value = value
  end
end

class Lambda
  attr_accessor :fn
  def initialize(fn)
    @fn = fn
  end
end

class App
  attr_accessor :fn, :val
  def initialize(f, v)
    @fn  = f
    @val = v
  end
end

# apply はAppオブジェクトを作ります。
# apply(fn).call(val) : apply は関数を引数にとり、val を引数としてcallされます。
def apply (fn) 
  lambda{|val| Thunk.new( lambda{ App.new(fn, val)} ) } 
end


class Evaluate
  attr_accessor :fn, :val
  def initialize(fn, val)
    @fn  = fn
    @val = val
  end
end

def evaluate(val) 
  while val.instance_of?(Thunk) 
    val = val.value.call
    if val.instance_of?(App)
      val = peelLambda(evaluate(val.fn)).call(val.val)
    end
  end
  val
end

def peelLambda (lam)
  unless lam.instance_of?(Lambda) 
    raise "type error: apply a non-lambda to a value"
  end
  lam.fn
end

y = Thunk.new(lambda{20})
x = Thunk.new(lambda{y})

p evaluate(x)  # => 20

add = Lambda.new(lambda{|x| Lambda.new(lambda{|y| Thunk.new(lambda{ evaluate(x) + evaluate(y)})})} )

sub = Lambda.new(lambda{|x| Lambda.new(lambda{|y| Thunk.new(lambda{ evaluate(x) - evaluate(y)})})} )

one = Thunk.new(lambda{1})
two = Thunk.new(lambda{2})

onetwo = Thunk.new(lambda{ apply( apply(add).call(one)).call(two) })
twoone = Thunk.new(lambda{ apply( apply(sub).call(one)).call(two) })

p evaluate(onetwo) # => 3
p evaluate(twoone) # => -1

class Cons
  attr_accessor :fn, :val
  def initialize(car, cdr)
    @car = car
    @cdr = cdr
  end
end

class Nil
  attr_reader :nil
  def initialize()
    @nil
  end
end


# []
nil_ =  Thunk.new(lambda{Nil.new()})

# (:)
cons = Lambda.new(lambda{|x| Lambda.new( lambda{|xs| Thunk.new( lambda{ Cons.new(x, xs)}) }) })

zero = Thunk.new(lambda{ 0 })

# let x = 0 : x
x = Thunk.new(lambda{ Cons.new(zero, x) })

print evaluate(x)   # => #<Cons:0x59ebd6c>