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)
#include "windows_cconv.h"
type SystemColor = UINT
cOLOR_SCROLLBAR :: SystemColor
cOLOR_SCROLLBAR = 0
cOLOR_BACKGROUND :: SystemColor
cOLOR_BACKGROUND = 1
cOLOR_ACTIVECAPTION :: SystemColor
cOLOR_ACTIVECAPTION = 2
cOLOR_INACTIVECAPTION :: SystemColor
cOLOR_INACTIVECAPTION = 3
cOLOR_MENU :: SystemColor
cOLOR_MENU = 4
cOLOR_WINDOW :: SystemColor
cOLOR_WINDOW = 5
cOLOR_WINDOWFRAME :: SystemColor
cOLOR_WINDOWFRAME = 6
cOLOR_MENUTEXT :: SystemColor
cOLOR_MENUTEXT = 7
cOLOR_WINDOWTEXT :: SystemColor
cOLOR_WINDOWTEXT = 8
cOLOR_CAPTIONTEXT :: SystemColor
cOLOR_CAPTIONTEXT = 9
cOLOR_ACTIVEBORDER :: SystemColor
cOLOR_ACTIVEBORDER = 10
cOLOR_INACTIVEBORDER :: SystemColor
cOLOR_INACTIVEBORDER = 11
cOLOR_APPWORKSPACE :: SystemColor
cOLOR_APPWORKSPACE = 12
cOLOR_HIGHLIGHT :: SystemColor
cOLOR_HIGHLIGHT = 13
cOLOR_HIGHLIGHTTEXT :: SystemColor
cOLOR_HIGHLIGHTTEXT = 14
cOLOR_BTNFACE :: SystemColor
cOLOR_BTNFACE = 15
cOLOR_BTNSHADOW :: SystemColor
cOLOR_BTNSHADOW = 16
cOLOR_GRAYTEXT :: SystemColor
cOLOR_GRAYTEXT = 17
cOLOR_BTNTEXT :: SystemColor
cOLOR_BTNTEXT = 18
cOLOR_INACTIVECAPTIONTEXT :: SystemColor
cOLOR_INACTIVECAPTIONTEXT = 19
cOLOR_BTNHIGHLIGHT :: SystemColor
cOLOR_BTNHIGHLIGHT = 20
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
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
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 -> 0
PaMips -> 1
PaAlpha -> 2
PaPpc -> 3
PaIa64 -> 6
PaIa32OnIa64 -> 10
PaAmd64 -> 9
peek buf = do
v <- (peekByteOff buf 0:: IO WORD)
return $ case v of
(0) -> PaIntel
(1) -> PaMips
(2) -> PaAlpha
(3) -> PaPpc
(6) -> PaIa64
(10) -> PaIa32OnIa64
(9) -> 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 (48)
alignment = sizeOf
poke buf si = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (siProcessorArchitecture si)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) buf (siPageSize si)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf (siMinimumApplicationAddress si)
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) buf (siMaximumApplicationAddress si)
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) buf (siActiveProcessorMask si)
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) buf (siNumberOfProcessors si)
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) buf (siProcessorType si)
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) buf (siAllocationGranularity si)
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) buf (siProcessorLevel si)
((\hsc_ptr -> pokeByteOff hsc_ptr 46)) buf (siProcessorRevision si)
peek buf = do
processorArchitecture <-
((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf
pageSize <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) buf
minimumApplicationAddress <-
((\hsc_ptr -> peekByteOff hsc_ptr 8)) buf
maximumApplicationAddress <-
((\hsc_ptr -> peekByteOff hsc_ptr 16)) buf
activeProcessorMask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) buf
numberOfProcessors <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) buf
processorType <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) buf
allocationGranularity <-
((\hsc_ptr -> peekByteOff hsc_ptr 40)) buf
processorLevel <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) buf
processorRevision <- ((\hsc_ptr -> peekByteOff hsc_ptr 46)) 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
type SMSetting = UINT
sM_ARRANGE :: SMSetting
sM_ARRANGE = 56
sM_CLEANBOOT :: SMSetting
sM_CLEANBOOT = 67
sM_CMETRICS :: SMSetting
sM_CMETRICS = 90
sM_CMOUSEBUTTONS :: SMSetting
sM_CMOUSEBUTTONS = 43
sM_CXBORDER :: SMSetting
sM_CXBORDER = 5
sM_CYBORDER :: SMSetting
sM_CYBORDER = 6
sM_CXCURSOR :: SMSetting
sM_CXCURSOR = 13
sM_CYCURSOR :: SMSetting
sM_CYCURSOR = 14
sM_CXDLGFRAME :: SMSetting
sM_CXDLGFRAME = 7
sM_CYDLGFRAME :: SMSetting
sM_CYDLGFRAME = 8
sM_CXDOUBLECLK :: SMSetting
sM_CXDOUBLECLK = 36
sM_CYDOUBLECLK :: SMSetting
sM_CYDOUBLECLK = 37
sM_CXDRAG :: SMSetting
sM_CXDRAG = 68
sM_CYDRAG :: SMSetting
sM_CYDRAG = 69
sM_CXEDGE :: SMSetting
sM_CXEDGE = 45
sM_CYEDGE :: SMSetting
sM_CYEDGE = 46
sM_CXFRAME :: SMSetting
sM_CXFRAME = 32
sM_CYFRAME :: SMSetting
sM_CYFRAME = 33
sM_CXFULLSCREEN :: SMSetting
sM_CXFULLSCREEN = 16
sM_CYFULLSCREEN :: SMSetting
sM_CYFULLSCREEN = 17
sM_CXHSCROLL :: SMSetting
sM_CXHSCROLL = 21
sM_CYVSCROLL :: SMSetting
sM_CYVSCROLL = 20
sM_CXICON :: SMSetting
sM_CXICON = 11
sM_CYICON :: SMSetting
sM_CYICON = 12
sM_CXICONSPACING :: SMSetting
sM_CXICONSPACING = 38
sM_CYICONSPACING :: SMSetting
sM_CYICONSPACING = 39
sM_CXMAXIMIZED :: SMSetting
sM_CXMAXIMIZED = 61
sM_CYMAXIMIZED :: SMSetting
sM_CYMAXIMIZED = 62
sM_CXMENUCHECK :: SMSetting
sM_CXMENUCHECK = 71
sM_CYMENUCHECK :: SMSetting
sM_CYMENUCHECK = 72
sM_CXMENUSIZE :: SMSetting
sM_CXMENUSIZE = 54
sM_CYMENUSIZE :: SMSetting
sM_CYMENUSIZE = 55
sM_CXMIN :: SMSetting
sM_CXMIN = 28
sM_CYMIN :: SMSetting
sM_CYMIN = 29
sM_CXMINIMIZED :: SMSetting
sM_CXMINIMIZED = 57
sM_CYMINIMIZED :: SMSetting
sM_CYMINIMIZED = 58
sM_CXMINTRACK :: SMSetting
sM_CXMINTRACK = 34
sM_CYMINTRACK :: SMSetting
sM_CYMINTRACK = 35
sM_CXSCREEN :: SMSetting
sM_CXSCREEN = 0
sM_CYSCREEN :: SMSetting
sM_CYSCREEN = 1
sM_CXSIZE :: SMSetting
sM_CXSIZE = 30
sM_CYSIZE :: SMSetting
sM_CYSIZE = 31
sM_CXSIZEFRAME :: SMSetting
sM_CXSIZEFRAME = 32
sM_CYSIZEFRAME :: SMSetting
sM_CYSIZEFRAME = 33
sM_CXSMICON :: SMSetting
sM_CXSMICON = 49
sM_CYSMICON :: SMSetting
sM_CYSMICON = 50
sM_CXSMSIZE :: SMSetting
sM_CXSMSIZE = 52
sM_CYSMSIZE :: SMSetting
sM_CYSMSIZE = 53
sM_CXVSCROLL :: SMSetting
sM_CXVSCROLL = 2
sM_CYHSCROLL :: SMSetting
sM_CYHSCROLL = 3
sM_CYVTHUMB :: SMSetting
sM_CYVTHUMB = 9
sM_CYCAPTION :: SMSetting
sM_CYCAPTION = 4
sM_CYKANJIWINDOW :: SMSetting
sM_CYKANJIWINDOW = 18
sM_CYMENU :: SMSetting
sM_CYMENU = 15
sM_CYSMCAPTION :: SMSetting
sM_CYSMCAPTION = 51
sM_DBCSENABLED :: SMSetting
sM_DBCSENABLED = 42
sM_DEBUG :: SMSetting
sM_DEBUG = 22
sM_MENUDROPALIGNMENT :: SMSetting
sM_MENUDROPALIGNMENT = 40
sM_MIDEASTENABLED :: SMSetting
sM_MIDEASTENABLED = 74
sM_MOUSEPRESENT :: SMSetting
sM_MOUSEPRESENT = 19
sM_NETWORK :: SMSetting
sM_NETWORK = 63
sM_PENWINDOWS :: SMSetting
sM_PENWINDOWS = 41
sM_SECURE :: SMSetting
sM_SECURE = 44
sM_SHOWSOUNDS :: SMSetting
sM_SHOWSOUNDS = 70
sM_SLOWMACHINE :: SMSetting
sM_SLOWMACHINE = 73
sM_SWAPBUTTON :: SMSetting
sM_SWAPBUTTON = 23