ドラッグ & ドロップしたファイルのパスをクリップボードにコピーする

Win32SDKを使って、ドラッグ & ドロップしたファイルのパスをクリップボードにコピーするプログラムを書いてみました。うーん、見事なほどにIOの山。ついでにスーパーpre記法のシンタックス・ハイライトを使ってソースコードに色をつけてみました。でもHaskellはあんまりきれいに色がつかないなー。
ファイル: pathcopy.hs

module Main (main) where

import Data.Bits ((.&.), (.|.))
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import Data.List (intersperse)
import Foreign.C.String (withCStringLen, peekCAString)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (castPtr)
import Graphics.Win32
import System.Exit (exitWith, ExitCode (ExitSuccess))
import System.Win32

putTextIntoClipboard :: String -> IO ()
putTextIntoClipboard s = 
  withCStringLen s $ \ (cstr, len) -> do
    let len' = fromInteger $ toInteger $ len + 1
    h <- globalAlloc (gMEM_DDESHARE .&. gMEM_MOVEABLE) len'
    s <- globalLock h
    copyMemory (castPtr s) cstr len'
    globalUnlock h
    openClipboard nullPtr
    emptyClipboard
    setClipboardData cF_TEXT h
    closeClipboard 

foreign import stdcall unsafe "DragQueryFileA" cDragQueryFile :: 
  WPARAM -> UINT -> LPTSTR -> UINT -> IO UINT

dragQueryFiles :: WPARAM -> IO [FilePath]
dragQueryFiles wParam = do
  f 0 =<< cDragQueryFile wParam (-1) nullPtr 0
  where
    bufSize = 4096

    f i n
      | i == n    = return []
      | otherwise = do
          file  <- allocaBytes bufSize $ \ p -> do 
                     cDragQueryFile wParam i p (fromInteger $ toInteger bufSize)
                     peekCAString $ castPtr p 
          files <- f (i + 1) n
          return $ file : files

createMainWindow :: String -> Pos -> Pos -> IORef [String] -> IO HWND
createMainWindow title width height var = do
  hinst  <- getModuleHandle Nothing
  icon   <- loadIcon   Nothing iDI_APPLICATION
  cursor <- loadCursor Nothing iDC_ARROW
  brush  <- getStockBrush lTGRAY_BRUSH
  registerClass 
    ((cS_HREDRAW .|. cS_VREDRAW), hinst, 
     Just icon, Just cursor, Just brush,
     Nothing, mkClassName $ title)
  hwnd <- createWindowEx
    wS_EX_ACCEPTFILES (mkClassName $ title) title
    wS_OVERLAPPEDWINDOW Nothing Nothing
    (Just width) (Just height) Nothing Nothing hinst $ wndProc var
  showWindow hwnd sW_SHOWNORMAL
  updateWindow hwnd
  return hwnd

wndProc :: IORef [String] -> HWND -> WindowMessage -> WPARAM -> LPARAM ->
           IO LRESULT
wndProc var hwnd wmsg wParam lParam
  | wmsg == wM_DESTROY     = onDestroy
  | wmsg == wM_PAINT       = onPaint
  | wmsg == wM_DROPFILES   = onDropFiles
  | wmsg == wM_LBUTTONDOWN = onClicked
  | wmsg == wM_KEYDOWN     = onKeyDown
  | otherwise              = defWindowProc (Just hwnd) wmsg wParam lParam
  where
    onDestroy = do
      putTextIntoClipboard . formatCopyString =<< readIORef var
      sendMessage hwnd wM_QUIT 1 0

    onPaint = do
      files <- readIORef var
      allocaPAINTSTRUCT $ \ lpps -> do
        hdc <- beginPaint hwnd lpps
        setBkMode hdc tRANSPARENT
        setTextColor hdc $ rgb 0 0 0
        textOut hdc 40 60 "Drop on me!!"
        textOut hdc 40 80 $ (show $ length files) ++ " files dropped."
        endPaint hwnd lpps
        updateWindow hwnd
        return 0

    onDropFiles = do
      files <- dragQueryFiles wParam
      modifyIORef var (\ ss -> ss ++ files)
      invalidateRect (Just hwnd) (Just nullPtr) True
      return 0

    onClicked = sendMessage hwnd wM_CLOSE 1 0
    onKeyDown = onClicked

messageLoop :: HWND -> IO ()
messageLoop = allocaMessage . loop
  where
    loop hwnd msg = do
      getMessage msg (Just hwnd)
        `catch` \ _ -> exitWith ExitSuccess
      translateMessage msg
      dispatchMessage msg
      loop hwnd msg

basename :: FilePath -> String
basename = reverse . takeWhile (/= '\\') . reverse

formatCopyString :: [FilePath] -> String
formatCopyString = concat . intersperse "\n" . map f
  where
    f file = "\x81\x9b " ++ basename file ++ "\n<" ++ file ++ ">\n"

main :: IO ()
main = messageLoop =<< createMainWindow "Drop on me!!" 200 200 =<< newIORef []

-- Local Variables:
-- compile-command: "ghc -W -fno-warn-unused-matches -optl-mwindows -ffi -package Win32 -lshell32 -o pathcopy pathcopy.hs"
-- End:

コンパイル方法。

$ ghc -W -fno-warn-unused-matches -optl-mwindows -ffi -package Win32 -lshell32 -o pathcopy pathcopy.hs

使い方。

• pathcopy.exeをダブルクリックして起動します。
• パスをコピーしたいファイルをウインドウの上にドラッグ & ドロップします。
• ウインドウを終了します。するとクリップボードにドラッグ & ドロップしたファイルのパスがコピーされています。ウィンドウにフォーカスを合わせて、マウスの左ボタンクリック、またはキーボードのキー押下でも終了できます。

参照: ログファイルの出力をのぞき見する方法