2006-12-15

■[Haskell] ドラッグ & ドロップしたファイルのパスをクリップボードにコピーする 23:35

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

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

■[Haskell] 指定した桁数で改行を入れる 02:30

おおー、id:hakobe932くんもHaskellかー。id:hakobe932:20061215:1166201940

僕も大体同じ動きをするプログラムを書いてみました。参考まで。

module Main (main) where

import System (getArgs)
import System.IO (stderr, hPutStrLn)

readFiles :: [String] -> IO String
readFiles []    = getContents
readFiles files = return . concat =<< mapM readFile files

groupn :: Int -> [a] -> [[a]]
groupn _ [] = []
groupn n s  = s1 : groupn n s2
  where
    (s1, s2) = splitAt n s

filln :: Int -> [FilePath] -> IO ()
filln column files =
  putStr . unlines . concatMap (groupn column) . lines =<< readFiles files

main :: IO ()
main = do
  args <- getArgs
  case args of
    (column : files) -> filln (read column) files
    _                -> usage
  where
    usage = hPutStrLn stderr $ "usage: filln column files..."