Source

haskell-win32 / System / Win32 / Info.hsc

Full commit
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  System.Win32.Info
-- Copyright   :  (c) Alastair Reid, 1997-2003
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
-- Stability   :  provisional
-- Portability :  portable
--
-- A collection of FFI declarations for interfacing with Win32.
--
-----------------------------------------------------------------------------

module System.Win32.Info where

import System.Win32.Types

import Prelude hiding (catch)
import Control.Exception (catch)
import System.IO.Error hiding (catch, try)
import Foreign      ( Storable(sizeOf, alignment, peekByteOff, pokeByteOff,
                               peek, poke)
                    , Ptr, alloca, allocaArray )

#include <windows.h>

----------------------------------------------------------------
-- Environment Strings
----------------------------------------------------------------

-- %fun ExpandEnvironmentStrings :: String -> IO String

----------------------------------------------------------------
-- Computer Name
----------------------------------------------------------------

-- %fun GetComputerName :: IO String
-- %fun SetComputerName :: String -> IO ()
-- %end free(arg1)

----------------------------------------------------------------
-- Hardware Profiles
----------------------------------------------------------------

-- %fun GetCurrentHwProfile :: IO HW_PROFILE_INFO

----------------------------------------------------------------
-- Keyboard Type
----------------------------------------------------------------

-- %fun GetKeyboardType :: KeyboardTypeKind -> IO KeyboardType

----------------------------------------------------------------
-- System Color
----------------------------------------------------------------

type SystemColor   = UINT

-- ToDo: This list is out of date.

#{enum SystemColor,
 , cOLOR_SCROLLBAR      = COLOR_SCROLLBAR
 , cOLOR_BACKGROUND     = COLOR_BACKGROUND
 , cOLOR_ACTIVECAPTION  = COLOR_ACTIVECAPTION
 , cOLOR_INACTIVECAPTION = COLOR_INACTIVECAPTION
 , cOLOR_MENU           = COLOR_MENU
 , cOLOR_WINDOW         = COLOR_WINDOW
 , cOLOR_WINDOWFRAME    = COLOR_WINDOWFRAME
 , cOLOR_MENUTEXT       = COLOR_MENUTEXT
 , cOLOR_WINDOWTEXT     = COLOR_WINDOWTEXT
 , cOLOR_CAPTIONTEXT    = COLOR_CAPTIONTEXT
 , cOLOR_ACTIVEBORDER   = COLOR_ACTIVEBORDER
 , cOLOR_INACTIVEBORDER = COLOR_INACTIVEBORDER
 , cOLOR_APPWORKSPACE   = COLOR_APPWORKSPACE
 , cOLOR_HIGHLIGHT      = COLOR_HIGHLIGHT
 , cOLOR_HIGHLIGHTTEXT  = COLOR_HIGHLIGHTTEXT
 , cOLOR_BTNFACE        = COLOR_BTNFACE
 , cOLOR_BTNSHADOW      = COLOR_BTNSHADOW
 , cOLOR_GRAYTEXT       = COLOR_GRAYTEXT
 , cOLOR_BTNTEXT        = COLOR_BTNTEXT
 , cOLOR_INACTIVECAPTIONTEXT = COLOR_INACTIVECAPTIONTEXT
 , cOLOR_BTNHIGHLIGHT   = COLOR_BTNHIGHLIGHT
 }

-- %fun GetSysColor :: SystemColor -> IO COLORREF
-- %fun SetSysColors :: [(SystemColor,COLORREF)] -> IO ()

----------------------------------------------------------------
-- Standard Directories
----------------------------------------------------------------

getSystemDirectory :: IO String
getSystemDirectory = try "GetSystemDirectory" c_getSystemDirectory 512

getWindowsDirectory :: IO String
getWindowsDirectory = try "GetWindowsDirectory" c_getWindowsDirectory 512

getCurrentDirectory :: IO String
getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512
getTemporaryDirectory :: IO String
getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512

getFullPathName :: FilePath -> IO FilePath
getFullPathName name = do
  withTString name $ \ c_name ->
    try "getFullPathName"
      (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512

searchPath :: Maybe String -> FilePath -> String -> IO (Maybe FilePath)
searchPath path filename ext =
  maybe ($ nullPtr) withTString path $ \p_path ->
  withTString filename $ \p_filename ->
  withTString ext      $ \p_ext ->
  alloca $ \ppFilePart -> (do
    s <- try "searchPath" (\buf len -> c_SearchPath p_path p_filename p_ext
                          len buf ppFilePart) 512
    return (Just s))
     `catch` \e -> if isDoesNotExistError e
                       then return Nothing
                       else ioError e

-- Support for API calls that are passed a fixed-size buffer and tell
-- you via the return value if the buffer was too small.  In that
-- case, we double the buffer size and try again.
try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String
try loc f n = do
   e <- allocaArray (fromIntegral n) $ \lptstr -> do
	  r <- failIfZero loc $ f lptstr n
	  if (r > n) then return (Left r) else do
	    str <- peekTStringLen (lptstr, fromIntegral r)
	    return (Right str)
   case e of
	Left n    -> try loc f n   
	Right str -> return str

foreign import stdcall unsafe "GetWindowsDirectoryW"
  c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT

foreign import stdcall unsafe "GetSystemDirectoryW"
  c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT

foreign import stdcall unsafe "GetCurrentDirectoryW"
  c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT

foreign import stdcall unsafe "GetTempPathW"
  c_getTempPath :: DWORD -> LPTSTR -> IO UINT

foreign import stdcall unsafe "GetFullPathNameW"
  c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD

foreign import stdcall unsafe "SearchPathW"
  c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR
               -> IO DWORD

----------------------------------------------------------------
-- System Info (Info about processor and memory subsystem)
----------------------------------------------------------------

data ProcessorArchitecture = PaUnknown WORD | PaIntel | PaMips | PaAlpha | PaPpc | PaIa64 | PaIa32OnIa64 | PaAmd64
    deriving (Show,Eq)

instance Storable ProcessorArchitecture where
    sizeOf _ = sizeOf (undefined::WORD)
    alignment _ = alignment (undefined::WORD)
    poke buf pa = pokeByteOff buf 0 $ case pa of
        PaUnknown w -> w
        PaIntel     -> #const PROCESSOR_ARCHITECTURE_INTEL
        PaMips      -> #const PROCESSOR_ARCHITECTURE_MIPS
        PaAlpha     -> #const PROCESSOR_ARCHITECTURE_ALPHA
        PaPpc       -> #const PROCESSOR_ARCHITECTURE_PPC
        PaIa64      -> #const PROCESSOR_ARCHITECTURE_IA64
#ifndef __WINE_WINDOWS_H
        PaIa32OnIa64 -> #const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
#endif
        PaAmd64     -> #const PROCESSOR_ARCHITECTURE_AMD64
    peek buf = do
        v <- (peekByteOff buf 0:: IO WORD)
        return $ case v of
            (#const PROCESSOR_ARCHITECTURE_INTEL) -> PaIntel
            (#const PROCESSOR_ARCHITECTURE_MIPS)  -> PaMips
            (#const PROCESSOR_ARCHITECTURE_ALPHA) -> PaAlpha
            (#const PROCESSOR_ARCHITECTURE_PPC)   -> PaPpc
            (#const PROCESSOR_ARCHITECTURE_IA64)  -> PaIa64
#ifndef __WINE_WINDOWS_H
            (#const PROCESSOR_ARCHITECTURE_IA32_ON_WIN64) -> PaIa32OnIa64
#endif
            (#const PROCESSOR_ARCHITECTURE_AMD64) -> PaAmd64
            w                                   -> PaUnknown w

data SYSTEM_INFO = SYSTEM_INFO
    { siProcessorArchitecture :: ProcessorArchitecture
    , siPageSize :: DWORD
    , siMinimumApplicationAddress, siMaximumApplicationAddress :: LPVOID
    , siActiveProcessorMask :: DWORD
    , siNumberOfProcessors :: DWORD
    , siProcessorType :: DWORD
    , siAllocationGranularity :: DWORD
    , siProcessorLevel :: WORD
    , siProcessorRevision :: WORD
    } deriving (Show)

instance Storable SYSTEM_INFO where
    sizeOf = const #size SYSTEM_INFO
    alignment = sizeOf
    poke buf si = do
        (#poke SYSTEM_INFO, wProcessorArchitecture) buf (siProcessorArchitecture si)
        (#poke SYSTEM_INFO, dwPageSize)             buf (siPageSize si)
        (#poke SYSTEM_INFO, lpMinimumApplicationAddress) buf (siMinimumApplicationAddress si)
        (#poke SYSTEM_INFO, lpMaximumApplicationAddress) buf (siMaximumApplicationAddress si)
        (#poke SYSTEM_INFO, dwActiveProcessorMask)  buf (siActiveProcessorMask si)
        (#poke SYSTEM_INFO, dwNumberOfProcessors)   buf (siNumberOfProcessors si)
        (#poke SYSTEM_INFO, dwProcessorType)        buf (siProcessorType si)
        (#poke SYSTEM_INFO, dwAllocationGranularity) buf (siAllocationGranularity si)
        (#poke SYSTEM_INFO, wProcessorLevel)        buf (siProcessorLevel si)
        (#poke SYSTEM_INFO, wProcessorRevision)     buf (siProcessorRevision si)

    peek buf = do
        processorArchitecture <-
            (#peek SYSTEM_INFO, wProcessorArchitecture) buf
        pageSize            <- (#peek SYSTEM_INFO, dwPageSize) buf
        minimumApplicationAddress <-
            (#peek SYSTEM_INFO, lpMinimumApplicationAddress) buf
        maximumApplicationAddress <-
            (#peek SYSTEM_INFO, lpMaximumApplicationAddress) buf
        activeProcessorMask <- (#peek SYSTEM_INFO, dwActiveProcessorMask) buf
        numberOfProcessors  <- (#peek SYSTEM_INFO, dwNumberOfProcessors) buf
        processorType       <- (#peek SYSTEM_INFO, dwProcessorType) buf
        allocationGranularity <-
            (#peek SYSTEM_INFO, dwAllocationGranularity) buf
        processorLevel      <- (#peek SYSTEM_INFO, wProcessorLevel) buf
        processorRevision   <- (#peek SYSTEM_INFO, wProcessorRevision) buf
        return $ SYSTEM_INFO {
            siProcessorArchitecture     = processorArchitecture,
            siPageSize                  = pageSize,
            siMinimumApplicationAddress = minimumApplicationAddress,
            siMaximumApplicationAddress = maximumApplicationAddress,
            siActiveProcessorMask       = activeProcessorMask,
            siNumberOfProcessors        = numberOfProcessors,
            siProcessorType             = processorType,
            siAllocationGranularity     = allocationGranularity,
            siProcessorLevel            = processorLevel,
            siProcessorRevision         = processorRevision
            }

foreign import stdcall unsafe "windows.h GetSystemInfo"
    c_GetSystemInfo :: Ptr SYSTEM_INFO -> IO ()

getSystemInfo :: IO SYSTEM_INFO
getSystemInfo = alloca $ \ret -> do
    c_GetSystemInfo ret
    peek ret

----------------------------------------------------------------
-- System metrics
----------------------------------------------------------------

type SMSetting = UINT

#{enum SMSetting,
 , sM_ARRANGE           = SM_ARRANGE
 , sM_CLEANBOOT         = SM_CLEANBOOT
 , sM_CMETRICS          = SM_CMETRICS
 , sM_CMOUSEBUTTONS     = SM_CMOUSEBUTTONS
 , sM_CXBORDER          = SM_CXBORDER
 , sM_CYBORDER          = SM_CYBORDER
 , sM_CXCURSOR          = SM_CXCURSOR
 , sM_CYCURSOR          = SM_CYCURSOR
 , sM_CXDLGFRAME        = SM_CXDLGFRAME
 , sM_CYDLGFRAME        = SM_CYDLGFRAME
 , sM_CXDOUBLECLK       = SM_CXDOUBLECLK
 , sM_CYDOUBLECLK       = SM_CYDOUBLECLK
 , sM_CXDRAG            = SM_CXDRAG
 , sM_CYDRAG            = SM_CYDRAG
 , sM_CXEDGE            = SM_CXEDGE
 , sM_CYEDGE            = SM_CYEDGE
 , sM_CXFRAME           = SM_CXFRAME
 , sM_CYFRAME           = SM_CYFRAME
 , sM_CXFULLSCREEN      = SM_CXFULLSCREEN
 , sM_CYFULLSCREEN      = SM_CYFULLSCREEN
 , sM_CXHSCROLL         = SM_CXHSCROLL
 , sM_CYVSCROLL         = SM_CYVSCROLL
 , sM_CXICON            = SM_CXICON
 , sM_CYICON            = SM_CYICON
 , sM_CXICONSPACING     = SM_CXICONSPACING
 , sM_CYICONSPACING     = SM_CYICONSPACING
 , sM_CXMAXIMIZED       = SM_CXMAXIMIZED
 , sM_CYMAXIMIZED       = SM_CYMAXIMIZED
 , sM_CXMENUCHECK       = SM_CXMENUCHECK
 , sM_CYMENUCHECK       = SM_CYMENUCHECK
 , sM_CXMENUSIZE        = SM_CXMENUSIZE
 , sM_CYMENUSIZE        = SM_CYMENUSIZE
 , sM_CXMIN             = SM_CXMIN
 , sM_CYMIN             = SM_CYMIN
 , sM_CXMINIMIZED       = SM_CXMINIMIZED
 , sM_CYMINIMIZED       = SM_CYMINIMIZED
 , sM_CXMINTRACK        = SM_CXMINTRACK
 , sM_CYMINTRACK        = SM_CYMINTRACK
 , sM_CXSCREEN          = SM_CXSCREEN
 , sM_CYSCREEN          = SM_CYSCREEN
 , sM_CXSIZE            = SM_CXSIZE
 , sM_CYSIZE            = SM_CYSIZE
 , sM_CXSIZEFRAME       = SM_CXSIZEFRAME
 , sM_CYSIZEFRAME       = SM_CYSIZEFRAME
 , sM_CXSMICON          = SM_CXSMICON
 , sM_CYSMICON          = SM_CYSMICON
 , sM_CXSMSIZE          = SM_CXSMSIZE
 , sM_CYSMSIZE          = SM_CYSMSIZE
 , sM_CXVSCROLL         = SM_CXVSCROLL
 , sM_CYHSCROLL         = SM_CYHSCROLL
 , sM_CYVTHUMB          = SM_CYVTHUMB
 , sM_CYCAPTION         = SM_CYCAPTION
 , sM_CYKANJIWINDOW     = SM_CYKANJIWINDOW
 , sM_CYMENU            = SM_CYMENU
 , sM_CYSMCAPTION       = SM_CYSMCAPTION
 , sM_DBCSENABLED       = SM_DBCSENABLED
 , sM_DEBUG             = SM_DEBUG
 , sM_MENUDROPALIGNMENT = SM_MENUDROPALIGNMENT
 , sM_MIDEASTENABLED    = SM_MIDEASTENABLED
 , sM_MOUSEPRESENT      = SM_MOUSEPRESENT
 , sM_NETWORK           = SM_NETWORK
 , sM_PENWINDOWS        = SM_PENWINDOWS
 , sM_SECURE            = SM_SECURE
 , sM_SHOWSOUNDS        = SM_SHOWSOUNDS
 , sM_SLOWMACHINE       = SM_SLOWMACHINE
 , sM_SWAPBUTTON        = SM_SWAPBUTTON
 }

-- %fun GetSystemMetrics :: SMSetting -> IO Int

----------------------------------------------------------------
-- Thread Desktops
----------------------------------------------------------------

-- %fun GetThreadDesktop :: ThreadId -> IO HDESK
-- %fun SetThreadDesktop :: ThreadId -> HDESK -> IO ()

----------------------------------------------------------------
-- User name
----------------------------------------------------------------

-- %fun GetUserName :: IO String

----------------------------------------------------------------
-- Version Info
----------------------------------------------------------------

-- %fun GetVersionEx :: IO VersionInfo
--
-- typedef struct _OSVERSIONINFO{
--     DWORD dwOSVersionInfoSize;
--     DWORD dwMajorVersion;
--     DWORD dwMinorVersion;
--     DWORD dwBuildNumber;
--     DWORD dwPlatformId;
--     TCHAR szCSDVersion[ 128 ];
-- } OSVERSIONINFO;

----------------------------------------------------------------
-- Processor features
----------------------------------------------------------------

--
-- Including these lines causes problems on Win95
-- %fun IsProcessorFeaturePresent :: ProcessorFeature -> Bool
--
-- type ProcessorFeature   = DWORD
-- %dis processorFeature x = dWORD x
--
-- %const ProcessorFeature
-- % [ PF_FLOATING_POINT_PRECISION_ERRATA
-- % , PF_FLOATING_POINT_EMULATED
-- % , PF_COMPARE_EXCHANGE_DOUBLE
-- % , PF_MMX_INSTRUCTIONS_AVAILABLE
-- % ]

----------------------------------------------------------------
-- System Parameter Information
----------------------------------------------------------------

-- %fun SystemParametersInfo :: ?? -> Bool -> IO ??

----------------------------------------------------------------
-- End
----------------------------------------------------------------