#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 -- 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 ---------------------------------------------------------------- -- 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 ----------------------------------------------------------------