FFI力養成訓練の結果(産廃)

WinMain.hs

{-# LANGUAGE ForeignFunctionInterface #-}

module Main where

import Foreign
import Control.Exception (bracket)
import Control.Monad
import Control.Monad.Cont ()
import Data.Maybe
import Graphics.Win32 hiding (moveWindow, c_MoveWindow) -- param type should be INT, not Int
import System.Exit
import System.Win32.DLL (getModuleHandle)
import System.Win32.Info
import System.Win32.Time

moveWindow :: HWND -> INT -> INT -> INT -> INT -> Bool -> IO ()
moveWindow wnd x y w h repaint =
  failIfFalse_ "MoveWindow" $ c_MoveWindow wnd x y w h repaint
foreign import stdcall "windows.h MoveWindow"
  c_MoveWindow :: HWND -> INT -> INT -> INT -> INT -> Bool -> IO Bool

patBlt :: HDC -> INT -> INT -> INT -> INT -> DWORD -> IO ()
patBlt hDc nXLeft nYLeft nWidth nHeight dwRop =
  failIfFalse_ "PatBlt" $ c_PatBlt hDc nXLeft nYLeft nWidth nHeight dwRop
foreign import stdcall "windows.h PatBlt"
  c_PatBlt :: HDC -> INT -> INT -> INT -> INT -> DWORD -> IO Bool

foreign import ccall unsafe "windows.h wsprintfW"
  wsprintf_WORD3 :: LPTSTR -> LPTSTR -> WORD -> WORD -> WORD -> IO INT

foreign import ccall unsafe "windows.h wsprintfW"
  wsprintf_WORD3_LPTSTR :: LPTSTR -> LPTSTR -> WORD -> WORD -> WORD -> LPTSTR -> IO INT

foreign import stdcall "windows.h PostMessageW"
  postMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT

foreign import stdcall "windows.h PostQuitMessage"
  postQuitMessage :: INT -> IO ()

foreign import stdcall unsafe "windows.h GetSystemMetrics"
  getSystemMetrics :: SMSetting -> IO INT

setWindowRgn :: HWND -> HRGN -> Bool -> IO ()
setWindowRgn hWnd hRgn bRepaint =
  withForeignPtr hRgn $ \pRgn ->
  failIfFalse_ "SetWindowRgn" $ c_SetWindowRgn hWnd pRgn bRepaint
foreign import stdcall safe "windows.h SetWindowRgn"
  c_SetWindowRgn :: HWND -> PRGN -> Bool -> IO Bool

deleteRgn :: HRGN -> IO ()
deleteRgn hRgn =
  withForeignPtr hRgn $ \pRgn ->
  failIfFalse_ "DeleteRgn" $ c_DeleteRgn pRgn
foreign import stdcall unsafe "windows.h DeleteObject"
  c_DeleteRgn :: PRGN -> IO Bool

hTCAPTION = 2

myTimer :: TimerId
myTimer = 1

clockWidth, clockHeight :: INT
clockWidth = 250
clockHeight = 60

clsName :: LPCTSTR
clsName = mkClassName "My Window Class"

registerMyClass :: IO (Maybe ATOM)
registerMyClass = do
  hInst           <- getModuleHandle Nothing
  whiteBrush      <- getStockBrush wHITE_BRUSH
  curArrow        <- loadCursor Nothing iDC_ARROW
  icoApplication  <- loadIcon Nothing iDI_APPLICATION
  mAtom           <- registerClass (
      cS_HREDRAW .|. cS_VREDRAW, 
      hInst,
      Just icoApplication,
      Just curArrow,
      Just whiteBrush,
      Nothing,
      clsName)
  return mAtom
  
unregisterMyClass :: IO ()
unregisterMyClass = do
  hInst    <- getModuleHandle Nothing
  unregisterClass clsName hInst

createMyWindow :: IO HWND
createMyWindow = do
  let style = wS_POPUP
  hInst <- getModuleHandle Nothing
  hWnd <- createWindow
    clsName
    "test window"
    style
    Nothing
    Nothing
    Nothing
    Nothing
    Nothing
    Nothing
    hInst
    wndProc
  return hWnd

main :: IO ()
main = do
  print "main"
  mAtom <- registerMyClass
  guard $ isJust mAtom
  hWnd <- createMyWindow
  showWindow hWnd sW_SHOWNORMAL
  updateWindow hWnd
  onCreate hWnd wM_CREATE 0 0
  messagePump hWnd
  unregisterMyClass

messagePump :: HWND -> IO ()
messagePump hWnd = allocaMessage pump
  where
    pump lpmsg = do
      getMessage lpmsg (Just hWnd)
        `catch` (const $ exitWith ExitSuccess)
      translateMessage lpmsg
      dispatchMessage lpmsg
      pump lpmsg    

onCreate :: WindowClosure
onCreate hWnd wm wp lp = do
  print "onCreate (emulated)"
  setWinTimer hWnd myTimer 500
  wx <- getSystemMetrics sM_CXSCREEN
  wy <- getSystemMetrics sM_CYSCREEN
  let x = (wx - clockWidth) `quot` 2
  let y = (wy - clockHeight) `quot` 2
  moveWindow hWnd x y clockWidth clockHeight True
  
  [hRgn, hRgn1, hRgn2] <- replicateM 3 $ createRectRgn 0 0 1 1
  hRound1Rgn <- createEllipticRgn 0 0 clockHeight clockHeight
  hRectRgn <- createRectRgn
    (clockHeight `quot` 2)
    0
    (clockWidth - clockHeight `quot` 2)
    clockHeight
  combineRgn hRgn1 hRound1Rgn hRectRgn rGN_OR
  hRound2Rgn <- createEllipticRgn
    (clockWidth - clockHeight)
    0
    clockWidth
    clockHeight
  combineRgn hRgn2 hRound2Rgn hRectRgn rGN_OR
  combineRgn hRgn hRgn1 hRgn2 rGN_OR
  setWindowRgn hWnd hRgn True
  
  deleteRgn hRound1Rgn
  deleteRgn hRound2Rgn
  deleteRgn hRectRgn
  deleteRgn hRgn1
  deleteRgn hRgn2
  return 0

wndProc :: WindowClosure
wndProc hWnd wm wp lp
  -- | wm == wM_CREATE       = print "onCreate" >> onCreate
  | wm == wM_RBUTTONDOWN  = onRButtonDown
  | wm == wM_LBUTTONDOWN  = onLButtonDown
  | wm == wM_TIMER        = onTimer
  | wm == wM_CLOSE        = onClose
  | wm == wM_DESTROY      = onDestroy
  | wm == wM_PAINT        = onPaint
  | otherwise             = defWindowProc (Just hWnd) wm wp lp
  where
    onRButtonDown = do
      print "onRButtonDown"
      sendMessage hWnd wM_CLOSE 0 0
    onLButtonDown = do
      print "onLButtonDown"
      postMessage hWnd wM_NCLBUTTONDOWN hTCAPTION lp
    onTimer
      | wp /= myTimer = defWindowProc (Just hWnd) wm wp lp
      | otherwise     = do
        st    <- getLocalTime
        withTString "%02d:%02d:%02d" $ \fmt ->
          wsprintf_WORD3 buf fmt (wHour st) (wMinute st) (wSecond st)
        withTString (["日","月","火","水","木","金","土"] !! (fromIntegral $ wDayOfWeek st)) $ \dow -> do
          withTString "%d/%02d/%02d(%s)" $ \fmt -> do
            wsprintf_WORD3_LPTSTR buf2 fmt (wYear st) (wMonth st) (wDay st) (dow)
        invalidateRect (Just hWnd) Nothing True
        return 0
    onPaint = do
      print "onPaint"
      allocaPAINTSTRUCT $ \lpps -> do
        bracket
          (beginPaint hWnd lpps)
          (const $ endPaint hWnd lpps)
          (draw)
        return 0
     where
        draw hdc = do
          let ofsY = 10
          hBrush <- createSolidBrush (rgb 255 255 128)
          selectBrush hdc hBrush
          patBlt hdc 0 0 clockWidth clockHeight pATCOPY
          
          hFont <- setMyFont "MS Gothic" 40
          selectFont hdc hFont
          str <- peekTString buf
          s <- getTextExtentPoint32 hdc str
          
          let x = (clockWidth - (fromIntegral $ fst s)) `quot` 2
          let y = (clockHeight - (fromIntegral $ snd s)) `quot` 2
          
          setBkMode hdc tRANSPARENT
          textOut hdc (fromIntegral x) (y + ofsY) str
          deleteFont hFont
          
          hFont2 <- setMyFont "MS Gothic" 14
          selectFont hdc hFont2
          str2 <- peekTString buf2
          s2 <- getTextExtentPoint32 hdc str2
          let x2 = (clockWidth - fst s2) `quot` 2
          textOut hdc x2 4 str2
          deleteFont hFont2
          
    onClose = do 
      print "onClose"
      defWindowProc (Just hWnd) wm wp lp
      return 0
    onDestroy = do
      print "onDestroy"
      killTimer (Just hWnd) myTimer
      postQuitMessage 0
      return 0
    [buf, buf2] = map (unsafePerformIO . newTString) $ replicate 2 $ replicate 1024 '\0'

setMyFont :: String -> INT -> IO HFONT
setMyFont face h = createFont
  h
  0
  0
  0
  fW_REGULAR
  False
  False
  False
  sHIFTJIS_CHARSET
  oUT_DEFAULT_PRECIS
  cLIP_DEFAULT_PRECIS
  pROOF_QUALITY
  (fIXED_PITCH .|. fF_MODERN)
  face