dist-install\build\System\Win32\Info.hs

    {-# LINE 1 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

    {-# LINE 2 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
    {-# LANGUAGE Safe #-}

    {-# LINE 6 "libraries\\Win32\\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 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)

    {-# LINE 34 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

    #include "windows_cconv.h"

    {-# LINE 38 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

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

    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

    {-# LINE 96 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

    -- %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     -> 0
    {-# LINE 180 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            PaMips      -> 1
    {-# LINE 181 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            PaAlpha     -> 2
    {-# LINE 182 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            PaPpc       -> 3
    {-# LINE 183 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            PaIa64      -> 6
    {-# LINE 184 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

    {-# LINE 185 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            PaIa32OnIa64 -> 10
    {-# LINE 186 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

    {-# LINE 187 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            PaAmd64     -> 9
    {-# LINE 188 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
        peek buf = do
            v <- (peekByteOff buf 0:: IO WORD)
            return $ case v of
                (0) -> PaIntel
    {-# LINE 192 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
                (1)  -> PaMips
    {-# LINE 193 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
                (2) -> PaAlpha
    {-# LINE 194 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
                (3)   -> PaPpc
    {-# LINE 195 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
                (6)  -> PaIa64
    {-# LINE 196 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

    {-# LINE 197 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
                (10) -> PaIa32OnIa64
    {-# LINE 198 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

    {-# LINE 199 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
                (9) -> PaAmd64
    {-# LINE 200 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
                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)
    {-# LINE 216 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
        alignment = sizeOf
        poke buf si = do
            ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (siProcessorArchitecture si)
    {-# LINE 219 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 4))             buf (siPageSize si)
    {-# LINE 220 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf (siMinimumApplicationAddress si)
    {-# LINE 221 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) buf (siMaximumApplicationAddress si)
    {-# LINE 222 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 24))  buf (siActiveProcessorMask si)
    {-# LINE 223 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 32))   buf (siNumberOfProcessors si)
    {-# LINE 224 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 36))        buf (siProcessorType si)
    {-# LINE 225 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 40)) buf (siAllocationGranularity si)
    {-# LINE 226 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 44))        buf (siProcessorLevel si)
    {-# LINE 227 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            ((\hsc_ptr -> pokeByteOff hsc_ptr 46))     buf (siProcessorRevision si)
    {-# LINE 228 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

        peek buf = do
            processorArchitecture <-
                ((\hsc_ptr -> peekByteOff hsc_ptr 0)) buf
    {-# LINE 232 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            pageSize            <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) buf
    {-# LINE 233 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            minimumApplicationAddress <-
                ((\hsc_ptr -> peekByteOff hsc_ptr 8)) buf
    {-# LINE 235 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            maximumApplicationAddress <-
                ((\hsc_ptr -> peekByteOff hsc_ptr 16)) buf
    {-# LINE 237 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            activeProcessorMask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) buf
    {-# LINE 238 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            numberOfProcessors  <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) buf
    {-# LINE 239 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            processorType       <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) buf
    {-# LINE 240 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            allocationGranularity <-
                ((\hsc_ptr -> peekByteOff hsc_ptr 40)) buf
    {-# LINE 242 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            processorLevel      <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) buf
    {-# LINE 243 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            processorRevision   <- ((\hsc_ptr -> peekByteOff hsc_ptr 46)) buf
    {-# LINE 244 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}
            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

    sM_ARRANGE            :: SMSetting
    sM_ARRANGE            =  56
    sM_CLEANBOOT          :: SMSetting
    sM_CLEANBOOT          =  67
    sM_CMETRICS           :: SMSetting
    sM_CMETRICS           =  97
    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

    {-# LINE 339 "libraries\\Win32\\System\\Win32\\Info.hsc" #-}

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