#if __GLASGOW_HASKELL__ >= 709 {-# LANGUAGE Safe #-} #elif __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 Control.Exception (catch) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray) import Foreign.Ptr (Ptr, nullPtr) import Foreign.Storable (Storable(..)) import System.IO.Error (isDoesNotExistError) import System.Win32.Types (DWORD, LPCTSTR, LPTSTR, LPVOID, UINT, WORD) import System.Win32.Types (failIfZero, peekTStringLen, withTString) #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif ##include "windows_cconv.h" #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 WINDOWS_CCONV unsafe "GetWindowsDirectoryW" c_getWindowsDirectory :: LPTSTR -> UINT -> IO UINT foreign import WINDOWS_CCONV unsafe "GetSystemDirectoryW" c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT foreign import WINDOWS_CCONV unsafe "GetCurrentDirectoryW" c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT foreign import WINDOWS_CCONV unsafe "GetTempPathW" c_getTempPath :: DWORD -> LPTSTR -> IO UINT foreign import WINDOWS_CCONV unsafe "GetFullPathNameW" c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD foreign import WINDOWS_CCONV 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 WINDOWS_CCONV 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 ----------------------------------------------------------------