Win32-2.2.1.0: System/Win32/Info.hsc
-----------------------------------------------------------------------------
-- |
-- 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
----------------------------------------------------------------