Windows環境でプログラミングHaskell第9章をやる為の準備

ShizuDevのHaskell勉強会で、プログラミングHaskell第9章”対話式プログラム”のスピーカーをやらせて頂きます。

第9章の中でターミナルの制御に、エスケープシーケンスを使っており、Windows環境の方は、「出来なくなってしまうのでは？」と思い調べましたら、ansi-terminalというGHCのライブラリがありましたので、それを入れる事により、ターミナル制御用の関数を提供してくれます。Hugsの方はスミマセン。

勉強会まで時間が無いという事もあり、取り急ぎやり方を羅列しておきます。

検証した環境 ： Windows XP SP3 ,GHC-6.10.4

GHCは恐らく、6.10.x系は大丈夫と思われます。GHC-6.12.x系は動きません。自分がそうでした。ディレクトリ構造を見たら、10から12で大きく変わってました。

cabal-installを入れる

ghcのパッケージインストールツールである”cabal-install”を入れます。
cabal-installのページ
cabal-installのダウンロードページ

ダウンロードページから、”cabal-install tool (version 0.8.2)”と書いてある下の”cabal.exe”をダウンロードします。

%HASKELL_HOME%\binに、先程ダウンロードした、”cabal.exe”をコピー or 移動します。%HASKELL_HOME%はGHCのインストールディレクトリです。PATHに%HASKELL_HOME%\binを通すのは、Windowsのインストーラがしてくれているハズです。

cabalの動作確認

以下はcabalの代表的な操作です。

#バージョン確認
cabal --version

#リポジトリリストの更新
cabal update

#cabalに対応するパッケージを確認
cabal list 

# インストール済みのパッケージ
cabal list --installed

#何が起こるか事前確認が出来る
cabal install パッケージ名 --dry-run 

#パッケージのインストール
cabal install パッケージ

#更新可能パッケージの確認
cabal upgrade --dry-run

#パッケージの更新
cabal upgrade

• • コマンドプロンプトを開いて「cabal --version」で、正しく動作するか確認します。

• • 次に、「cabal update」でcabalのリポジトリリストを更新します。更新が完了すると「C:\Documents and Settings\ユーザ\Application Data\cabal」にディレクトリが、出来てここにパッケージが入ります。

ansi-terminalのインストール

• • 「cabal install ansi-terminal」を実行してansi-terminalパッケージをインストールします。
  • ansi-terminalの公式サイト
  • HackageDB (ansi-terminal)

ソースは勉強会、当日にもお知らせしますので、Windowsの方は、環境だけでも作っておいてください。
お忙しいとは思いますがお願い致します。

以下は、本に記載で使えない関数の代表的な代替え関数です。

カーソル位置と画面クリアは、勉強会の結果、ansi-terminalで、簡単に出来る事が分かりましたので、こちらで訂正しております。

代替えの関数の抜粋

カーソルポジション用「setCursorPosition」関数

■Win32ANSI.hs（本はputStr "\ESC[x;yH"）

{-# LANGUAGE ForeignFunctionInterface#-}
module Win32ANSI (setCursorPosition) where

import System.IO
import System.Win32.Types

import Data.Bits

import Foreign.C.Types
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Foreign.StablePtr

import Control.Concurrent.MVar
import Control.Exception (bracket)

import GHC.IOBase (Handle(..) ,Handle__(..) ,FD )

hSetCursorPosition :: Handle
                   -> Int 
                   -> Int 
                   -> IO ()
setCursorPosition :: Int 
                  -> Int 
                  -> IO ()

setCursorPosition = hSetCursorPosition stdout

withHandle :: Handle -> (HANDLE -> IO a) -> IO a
withHandle handle action = do
    hFlush handle
    withHandleToHANDLE handle action

adjustCursorPosition :: HANDLE -> (SHORT -> SHORT -> SHORT) -> (SHORT -> SHORT -> SHORT) -> IO ()
adjustCursorPosition handle change_x change_y = do
    screen_buffer_info <- getConsoleScreenBufferInfo handle
    let window = csbi_window screen_buffer_info
        (COORD x y) = csbi_cursor_position screen_buffer_info
        cursor_pos' = COORD (change_x (rect_left window) x) (change_y (rect_top window) y)
    setConsoleCursorPosition handle cursor_pos'

hSetCursorPosition h y x = withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\window_top _ -> window_top + fromIntegral y)




type SHORT = CShort

type UNPACKED_COORD = CInt

unpackCOORD :: COORD -> UNPACKED_COORD
unpackCOORD (COORD x y) = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x)


peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b)
peekAndOffset ptr = do
    item <- peek ptr
    return (item, ptr `plusPtr` sizeOf item)

pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b)
pokeAndOffset ptr item = do
    poke ptr item
    return (ptr `plusPtr` sizeOf item)


data COORD = COORD {
        coord_x :: SHORT,
        coord_y :: SHORT
    }

instance Show COORD where
    show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")"

instance Storable COORD where
    sizeOf ~(COORD x y) = sizeOf x + sizeOf y
    alignment ~(COORD x _) = alignment x
    peek ptr = do
        let ptr' = castPtr ptr :: Ptr SHORT
        x <- peekElemOff ptr' 0
        y <- peekElemOff ptr' 1
        return (COORD x y)
    poke ptr (COORD x y) = do
        let ptr' = castPtr ptr :: Ptr SHORT
        pokeElemOff ptr' 0 x
        pokeElemOff ptr' 1 y


data SMALL_RECT = SMALL_RECT {
        rect_top_left :: COORD,
        rect_bottom_right :: COORD
    }

rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT
rect_top = coord_y . rect_top_left
rect_left = coord_x . rect_top_left
rect_bottom = coord_y . rect_bottom_right
rect_right = coord_x . rect_bottom_right

instance Show SMALL_RECT where
    show (SMALL_RECT tl br) = show tl ++ "-" ++ show br

instance Storable SMALL_RECT where
    sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br
    alignment ~(SMALL_RECT tl _) = alignment tl
    peek ptr = do
        let ptr' = castPtr ptr :: Ptr COORD
        tl <- peekElemOff ptr' 0
        br <- peekElemOff ptr' 1
        return (SMALL_RECT tl br)
    poke ptr (SMALL_RECT tl br) = do
        let ptr' = castPtr ptr :: Ptr COORD
        pokeElemOff ptr' 0 tl
        pokeElemOff ptr' 1 br


data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO {
        csbi_size :: COORD,
        csbi_cursor_position :: COORD,
        csbi_attributes :: WORD,
        csbi_window :: SMALL_RECT,
        csbi_maximum_window_size :: COORD
    }
    deriving (Show)

instance Storable CONSOLE_SCREEN_BUFFER_INFO where
    sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size)
      = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + sizeOf maximum_window_size
    alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size
    peek ptr = do
        (size, ptr1) <- peekAndOffset (castPtr ptr)
        (cursor_position, ptr2) <- peekAndOffset ptr1
        (attributes, ptr3) <- peekAndOffset ptr2
        (window, ptr4) <- peekAndOffset ptr3
        maximum_window_size <- peek ptr4
        return (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size)
    poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do
        ptr1 <- pokeAndOffset (castPtr ptr) size
        ptr2 <- pokeAndOffset ptr1 cursor_position
        ptr3 <- pokeAndOffset ptr2 attributes
        ptr4 <- pokeAndOffset ptr3 window
        poke ptr4 maximum_window_size

foreign import stdcall unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL

foreign import stdcall unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL
foreign import stdcall unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL



getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO
getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do
    failIfFalse_ "getConsoleScreenBufferInfo" $ cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info
    peek ptr_console_screen_buffer_info


setConsoleCursorPosition :: HANDLE -> COORD -> IO ()
setConsoleCursorPosition handle cursor_position = failIfFalse_ "setConsoleCursorPosition" $ cSetConsoleCursorPosition handle (unpackCOORD cursor_position)


foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: FD -> IO HANDLE

withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE haskell_handle action = 
    withStablePtr haskell_handle $ const $ do
        let write_handle_mvar = case haskell_handle of
                FileHandle _ handle_mvar     -> handle_mvar
                DuplexHandle _ _ handle_mvar -> handle_mvar
        
        fd <- fmap haFD $ readMVar write_handle_mvar
        
        windows_handle <- cget_osfhandle fd
        
        action windows_handle

withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
withStablePtr value = bracket (newStablePtr value) freeStablePtr

■画面消去

import System.Cmd (system)


cls            :: IO ()
cls            =  do system("cls")
                     return ()

■ビープ音

beep                          :: IO ()
beep                          =  do putStr "\BEL"
                                    hFlush stdout

■標準入力読取（入力した文字を表示させない）

getCh                         :: IO Char
getCh                         =  liftM (chr . fromEnum) c_getch
foreign import ccall unsafe "conio.h getch" c_getch :: IO CInt