diff --git a/Graphics/Win32/Window.hsc b/Graphics/Win32/Window.hsc --- a/Graphics/Win32/Window.hsc +++ b/Graphics/Win32/Window.hsc @@ -419,7 +419,7 @@ return size' foreign import WINDOWS_CCONV "windows.h GetWindowTextLengthW" c_GetWindowTextLength :: HWND -> IO Int - + ---------------------------------------------------------------- -- Paint struct ---------------------------------------------------------------- @@ -471,6 +471,9 @@ foreign import WINDOWS_CCONV "windows.h ShowWindow" showWindow :: HWND -> ShowWindowControl -> IO Bool +foreign import WINDOWS_CCONV "windows.h IsWindowVisible" + isWindowVisible :: HWND -> IO Bool + ---------------------------------------------------------------- -- Misc ---------------------------------------------------------------- @@ -607,7 +610,7 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetForegroundWindow" getForegroundWindow :: IO HWND - + getParent :: HWND -> IO HWND getParent wnd = failIfNull "GetParent" $ c_GetParent wnd diff --git a/System/Win32/Console.hsc b/System/Win32/Console.hsc --- a/System/Win32/Console.hsc +++ b/System/Win32/Console.hsc @@ -170,8 +170,8 @@ (#poke CONSOLE_SCREEN_BUFFER_INFO, dwMaximumWindowSize) buf (dwMaximumWindowSize info) data COORD = COORD - { x :: SHORT - , y :: SHORT + { xPos :: SHORT + , yPos :: SHORT } deriving (Show, Eq) instance Storable COORD where @@ -182,14 +182,14 @@ y' <- (#peek COORD, Y) buf return $ COORD x' y' poke buf coord = do - (#poke COORD, X) buf (x coord) - (#poke COORD, Y) buf (y coord) + (#poke COORD, X) buf (xPos coord) + (#poke COORD, Y) buf (yPos coord) data SMALL_RECT = SMALL_RECT - { left :: SHORT - , top :: SHORT - , right :: SHORT - , bottom :: SHORT + { leftPos :: SHORT + , topPos :: SHORT + , rightPos :: SHORT + , bottomPos :: SHORT } deriving (Show, Eq) instance Storable SMALL_RECT where @@ -202,10 +202,10 @@ bottom' <- (#peek SMALL_RECT, Bottom) buf return $ SMALL_RECT left' top' right' bottom' poke buf small_rect = do - (#poke SMALL_RECT, Left) buf (left small_rect) - (#poke SMALL_RECT, Top) buf (top small_rect) - (#poke SMALL_RECT, Right) buf (right small_rect) - (#poke SMALL_RECT, Bottom) buf (bottom small_rect) + (#poke SMALL_RECT, Left) buf (leftPos small_rect) + (#poke SMALL_RECT, Top) buf (topPos small_rect) + (#poke SMALL_RECT, Right) buf (rightPos small_rect) + (#poke SMALL_RECT, Bottom) buf (bottomPos small_rect) foreign import WINDOWS_CCONV safe "windows.h GetConsoleScreenBufferInfo" c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL diff --git a/System/Win32/NLS.hsc b/System/Win32/NLS.hsc --- a/System/Win32/NLS.hsc +++ b/System/Win32/NLS.hsc @@ -22,17 +22,42 @@ mAKELANGID, pRIMARYLANGID, sUBLANGID ) where +import System.Win32.String (withTStringBufferLen) import System.Win32.Types +import System.Win32.Utils (trySized) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +import Control.Monad (when) +import Data.IORef (modifyIORef, newIORef, readIORef) import Foreign import Foreign.C +import Text.Printf (printf) ##include "windows_cconv.h" +-- Somewhere, WINVER and _WIN32_WINNT are being defined as less than 0x0600 - +-- that is, before Windows Vista. Support for Windows XP was dropped in +-- GHC 8.0.1 of May 2016. This forces them to be at least 0x0600. +#if WINVER < 0x0600 +#undef WINVER +#define WINVER 0x0600 +#endif +#if _WIN32_WINNT < 0x0600 +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0600 +#endif + #include +#include "alignment.h" #include "errors.h" #include "win32debug.h" +#include "winnls_compat.h" +#include "winnt_compat.h" +type NLS_FUNCTION = DWORD + #{enum LCID, , lOCALE_SYSTEM_DEFAULT = LOCALE_SYSTEM_DEFAULT , lOCALE_USER_DEFAULT = LOCALE_USER_DEFAULT @@ -60,37 +85,237 @@ type LCTYPE = UINT +-- The following locale information constants are excluded from the `enum` list +-- below, for the reason indicated: +-- LOCALE_IDIALINGCODE -- Introduced in Windows 10 but not supported. Synonym + -- for LOCALE_ICOUNTRY. +-- LOCALE_INEGATIVEPERCENT -- Introduced in Windows 7 but not supported. +-- LOCALE_IPOSITIVEPERCENT -- Introduced in Windows 7 but not supported. +-- LOCALE_IREADINGLAYOUT -- Introduced in Windows 7 but not supported. +-- LOCALE_SAM -- Introduced by Windows 10 but not supported. Synonyn for + -- LOCALE_S1159. +-- LOCALE_SENGLISHDISPLAYNAME -- Introduced in Windows 7 but not supported. +-- LOCALE_SIETFLANGUAGE -- Not supported (deprecated from Windows Vista). +-- LOCALE_SNATIVEDISPLAYNAME -- Introduced in Windows 7 but not supported. +-- LOCALE_SNATIVELANGUAGENAME -- Introduced in Windows 7 but not supported. +-- LOCALE_SPERCENT -- Introduced in Windows 7 but not supported. +-- LOCALE_SPM -- Introduced in Windows 10 but not supported. Synonym for + -- LOCALE_S2359. +-- LOCALE_SSHORTESTAM -- Not supported. +-- LOCALE_SSHORTESTPM -- Not supported. +-- LOCALE_SSHORTTIME -- Introduced in Windows 7 but not supported. + +-- The following locale information constant is included in the list below, but +-- note: +-- LOCALE_IINTLCURRDIGITS -- Not supported by Windows 10, use + -- LOCALE_ICURRDIGITS. + #{enum LCTYPE, + , lOCALE_FONTSIGNATURE = LOCALE_FONTSIGNATURE , lOCALE_ICALENDARTYPE = LOCALE_ICALENDARTYPE - , lOCALE_SDATE = LOCALE_SDATE + , lOCALE_ICENTURY = LOCALE_ICENTURY + , lOCALE_ICOUNTRY = LOCALE_ICOUNTRY , lOCALE_ICURRDIGITS = LOCALE_ICURRDIGITS - , lOCALE_SDECIMAL = LOCALE_SDECIMAL , lOCALE_ICURRENCY = LOCALE_ICURRENCY - , lOCALE_SGROUPING = LOCALE_SGROUPING + , lOCALE_IDATE = LOCALE_IDATE + , lOCALE_IDAYLZERO = LOCALE_IDAYLZERO + , lOCALE_IDEFAULTANSICODEPAGE = LOCALE_IDEFAULTANSICODEPAGE + , lOCALE_IDEFAULTCODEPAGE = LOCALE_IDEFAULTCODEPAGE + , lOCALE_IDEFAULTCOUNTRY = LOCALE_IDEFAULTCOUNTRY + , lOCALE_IDEFAULTEBCDICCODEPAGE = LOCALE_IDEFAULTEBCDICCODEPAGE + , lOCALE_IDEFAULTLANGUAGE = LOCALE_IDEFAULTLANGUAGE + , lOCALE_IDEFAULTMACCODEPAGE = LOCALE_IDEFAULTMACCODEPAGE , lOCALE_IDIGITS = LOCALE_IDIGITS - , lOCALE_SLIST = LOCALE_SLIST + , lOCALE_IDIGITSUBSTITUTION = LOCALE_IDIGITSUBSTITUTION , lOCALE_IFIRSTDAYOFWEEK = LOCALE_IFIRSTDAYOFWEEK - , lOCALE_SLONGDATE = LOCALE_SLONGDATE , lOCALE_IFIRSTWEEKOFYEAR = LOCALE_IFIRSTWEEKOFYEAR - , lOCALE_SMONDECIMALSEP = LOCALE_SMONDECIMALSEP + , lOCALE_IGEOID = LOCALE_IGEOID + , lOCALE_IINTLCURRDIGITS = LOCALE_IINTLCURRDIGITS + , lOCALE_ILANGUAGE = LOCALE_ILANGUAGE + , lOCALE_ILDATE = LOCALE_ILDATE , lOCALE_ILZERO = LOCALE_ILZERO - , lOCALE_SMONGROUPING = LOCALE_SMONGROUPING , lOCALE_IMEASURE = LOCALE_IMEASURE - , lOCALE_SMONTHOUSANDSEP = LOCALE_SMONTHOUSANDSEP + , lOCALE_IMONLZERO = LOCALE_IMONLZERO , lOCALE_INEGCURR = LOCALE_INEGCURR - , lOCALE_SNEGATIVESIGN = LOCALE_SNEGATIVESIGN , lOCALE_INEGNUMBER = LOCALE_INEGNUMBER + , lOCALE_INEGSEPBYSPACE = LOCALE_INEGSEPBYSPACE + , lOCALE_INEGSIGNPOSN = LOCALE_INEGSIGNPOSN + , lOCALE_INEGSYMPRECEDES = LOCALE_INEGSYMPRECEDES + , lOCALE_IOPTIONALCALENDAR = LOCALE_IOPTIONALCALENDAR + , lOCALE_PAPERSIZE = LOCALE_IPAPERSIZE + , lOCALE_IPOSSEPBYSPACE = LOCALE_IPOSSEPBYSPACE + , lOCALE_IPOSSIGNPOSN = LOCALE_IPOSSIGNPOSN + , lOCALE_IPSSYMPRECEDES = LOCALE_IPOSSYMPRECEDES + , lOCALE_ITIME = LOCALE_ITIME + , lOCALE_ITIMEMARKPOSN = LOCALE_ITIMEMARKPOSN + , lOCALE_ITLZERO = LOCALE_ITLZERO + , lOCALE_RETURN_NUMBER = LOCALE_RETURN_NUMBER + , lOCALE_S1159 = LOCALE_S1159 + , lOCALE_S2359 = LOCALE_S2359 + , lOCALE_SABBREVCTRYNAME = LOCALE_SABBREVCTRYNAME + , lOCALE_SABBREVDAYNAME1 = LOCALE_SABBREVDAYNAME1 + , lOCALE_SABBREVDAYNAME2 = LOCALE_SABBREVDAYNAME2 + , lOCALE_SABBREVDAYNAME3 = LOCALE_SABBREVDAYNAME3 + , lOCALE_SABBREVDAYNAME4 = LOCALE_SABBREVDAYNAME4 + , lOCALE_SABBREVDAYNAME5 = LOCALE_SABBREVDAYNAME5 + , lOCALE_SABBREVDAYNAME6 = LOCALE_SABBREVDAYNAME6 + , lOCALE_SABBREVDAYNAME7 = LOCALE_SABBREVDAYNAME7 + , lOCALE_SABBREVLANGNAME = LOCALE_SABBREVLANGNAME + , lOCALE_SABBREVMONTHNAME1 = LOCALE_SABBREVMONTHNAME1 + , lOCALE_SABBREVMONTHNAME2 = LOCALE_SABBREVMONTHNAME2 + , lOCALE_SABBREVMONTHNAME3 = LOCALE_SABBREVMONTHNAME3 + , lOCALE_SABBREVMONTHNAME4 = LOCALE_SABBREVMONTHNAME4 + , lOCALE_SABBREVMONTHNAME5 = LOCALE_SABBREVMONTHNAME5 + , lOCALE_SABBREVMONTHNAME6 = LOCALE_SABBREVMONTHNAME6 + , lOCALE_SABBREVMONTHNAME7 = LOCALE_SABBREVMONTHNAME7 + , lOCALE_SABBREVMONTHNAME8 = LOCALE_SABBREVMONTHNAME8 + , lOCALE_SABBREVMONTHNAME9 = LOCALE_SABBREVMONTHNAME9 + , lOCALE_SABBREVMONTHNAME10 = LOCALE_SABBREVMONTHNAME10 + , lOCALE_SABBREVMONTHNAME11 = LOCALE_SABBREVMONTHNAME11 + , lOCALE_SABBREVMONTHNAME12 = LOCALE_SABBREVMONTHNAME12 + , lOCALE_SABBREVMONTHNAME13 = LOCALE_SABBREVMONTHNAME13 + , lOCALE_SCONSOLEFALLBACKNAME = LOCALE_SCONSOLEFALLBACKNAME + , lOCALE_SCURRENCY = LOCALE_SCURRENCY + , lOCALE_SDATE = LOCALE_SDATE + , lOCALE_SDAYNAME1 = LOCALE_SDAYNAME1 + , lOCALE_SDAYNAME2 = LOCALE_SDAYNAME2 + , lOCALE_SDAYNAME3 = LOCALE_SDAYNAME3 + , lOCALE_SDAYNAME4 = LOCALE_SDAYNAME4 + , lOCALE_SDAYNAME5 = LOCALE_SDAYNAME5 + , lOCALE_SDAYNAME6 = LOCALE_SDAYNAME6 + , lOCALE_SDAYNAME7 = LOCALE_SDAYNAME7 + , lOCALE_SDECIMAL = LOCALE_SDECIMAL + , lOCALE_SDURATION = LOCALE_SDURATION + , lOCALE_SENGCURRNAME = LOCALE_SENGCURRNAME + , lOCALE_SENGLISHCOUNTRYNAME = LOCALE_SENGLISHCOUNTRYNAME + , lOCALE_SENGLISHLANGUAGENAME = LOCALE_SENGLISHLANGUAGENAME + , lOCALE_SGROUPING = LOCALE_SGROUPING + , lOCALE_SINTLSYMBOL = LOCALE_SINTLSYMBOL + , lOCALE_SISO3166CTRYNAME = LOCALE_SISO3166CTRYNAME + , lOCALE_SISO3166CTRYNAME2 = LOCALE_SISO3166CTRYNAME2 + , lOCALE_SISO639LANGNAME = LOCALE_SISO639LANGNAME + , lOCALE_SISO639LANGNAME2 = LOCALE_SISO639LANGNAME2 + , lOCALE_SKEYBOARDSTOINSTALL = LOCALE_SKEYBOARDSTOINSTALL + , lOCALE_SLIST = LOCALE_SLIST + , lOCALE_SLONGDATE = LOCALE_SLONGDATE + , lOCALE_SMONDECIMALSEP = LOCALE_SMONDECIMALSEP + , lOCALE_SMONGROUPING = LOCALE_SMONGROUPING + , lOCALE_SMONTHNAME1 = LOCALE_SMONTHNAME1 + , lOCALE_SMONTHNAME2 = LOCALE_SMONTHNAME2 + , lOCALE_SMONTHNAME3 = LOCALE_SMONTHNAME3 + , lOCALE_SMONTHNAME4 = LOCALE_SMONTHNAME4 + , lOCALE_SMONTHNAME5 = LOCALE_SMONTHNAME5 + , lOCALE_SMONTHNAME6 = LOCALE_SMONTHNAME6 + , lOCALE_SMONTHNAME7 = LOCALE_SMONTHNAME7 + , lOCALE_SMONTHNAME8 = LOCALE_SMONTHNAME8 + , lOCALE_SMONTHNAME9 = LOCALE_SMONTHNAME9 + , lOCALE_SMONTHNAME10 = LOCALE_SMONTHNAME10 + , lOCALE_SMONTHNAME11 = LOCALE_SMONTHNAME11 + , lOCALE_SMONTHNAME12 = LOCALE_SMONTHNAME12 + , lOCALE_SMONTHNAME13 = LOCALE_SMONTHNAME13 + , lOCALE_SMONTHOUSANDSEP = LOCALE_SMONTHOUSANDSEP + , lOCALE_SNAME = LOCALE_SNAME + , lOCALE_SNAN = LOCALE_SNAN + , lOCALE_SNATIVECOUNTRYNAME = LOCALE_SNATIVECOUNTRYNAME + , lOCALE_SNATIVECURRNAME = LOCALE_SNATIVECURRNAME + , lOCALE_SNATIVEDIGITS = LOCALE_SNATIVEDIGITS + , lOCALE_SNEGATIVESIGN = LOCALE_SNEGATIVESIGN + , lOCALE_SNEGINFINITY = LOCALE_SNEGINFINITY + , lOCALE_SPARENT = LOCALE_SPARENT + , lOCALE_SPOSINFINITY = LOCALE_SPOSINFINITY , lOCALE_SPOSITIVESIGN = LOCALE_SPOSITIVESIGN + , lOCALE_SSCRIPTS = LOCALE_SSCRIPTS , lOCALE_SSHORTDATE = LOCALE_SSHORTDATE - , lOCALE_ITIME = LOCALE_ITIME + , lOCALE_SSHORTESTDAYNAME1 = LOCALE_SSHORTESTDAYNAME1 + , lOCALE_SSHORTESTDAYNAME2 = LOCALE_SSHORTESTDAYNAME2 + , lOCALE_SSHORTESTDAYNAME3 = LOCALE_SSHORTESTDAYNAME3 + , lOCALE_SSHORTESTDAYNAME4 = LOCALE_SSHORTESTDAYNAME4 + , lOCALE_SSHORTESTDAYNAME5 = LOCALE_SSHORTESTDAYNAME5 + , lOCALE_SSHORTESTDAYNAME6 = LOCALE_SSHORTESTDAYNAME6 + , lOCALE_SSHORTESTDAYNAME7 = LOCALE_SSHORTESTDAYNAME7 + , lOCALE_SSORTNAME = LOCALE_SSORTNAME , lOCALE_STHOUSAND = LOCALE_STHOUSAND - , lOCALE_S1159 = LOCALE_S1159 , lOCALE_STIME = LOCALE_STIME - , lOCALE_S2359 = LOCALE_S2359 , lOCALE_STIMEFORMAT = LOCALE_STIMEFORMAT - , lOCALE_SCURRENCY = LOCALE_SCURRENCY + , lOCALE_SYEARMONTH = LOCALE_SYEARMONTH } +-- |Type representing locale data +data LCData + -- | Data in the form of a Unicode string. + = LCTextualData !String + -- | Data in the form of a number. See 'lOCAL_RETURN_NUMBER' and @LOCAL_I*@ + -- locate information constants. + | LCNumericData !DWORD + -- | Data in the fomr of a 'LOCALESIGNATURE'. See 'lOCAL_FONTSIGNATURE' locale + -- information constant. + | LCSignatureData !LOCALESIGNATURE + deriving (Eq, Show) + +data LOCALESIGNATURE = LOCALESIGNATURE + { lsUsb :: !UnicodeSubsetBitfield + , lsCsbDefault :: !DDWORD + , lsCsbSupported :: !DDWORD + } deriving (Eq, Show) + +instance Storable LOCALESIGNATURE where + sizeOf = const #{size LOCALESIGNATURE} + alignment _ = #alignment LOCALESIGNATURE + peek buf = do + lsUsb' <- (#peek LOCALESIGNATURE, lsUsb) buf + lsCsbDefault' <- (#peek LOCALESIGNATURE, lsCsbDefault) buf + lsCsbSupported' <- (#peek LOCALESIGNATURE, lsCsbSupported) buf + return $ LOCALESIGNATURE lsUsb' lsCsbDefault' lsCsbSupported' + poke buf info = do + (#poke LOCALESIGNATURE, lsUsb) buf (lsUsb info) + (#poke LOCALESIGNATURE, lsCsbDefault) buf (lsCsbDefault info) + (#poke LOCALESIGNATURE, lsCsbSupported) buf (lsCsbSupported info) + +-- | Type representing 128-bit Unicode subset bitfields, as the @base@ package +-- does include a module exporting a 128-bit unsigned integer type. +data UnicodeSubsetBitfield = UnicodeSubsetBitfield + { usbLow :: !DDWORD + , usbHigh :: !DDWORD + } deriving (Eq, Show) + +instance Storable UnicodeSubsetBitfield where + sizeOf _ = 2 * sizeOf (undefined :: DDWORD) + alignment _ = alignment (undefined :: DWORD) + peek buf = do + usbLow' <- (peekByteOff buf 0 :: IO DDWORD) + usbHigh' <- (peekByteOff buf (sizeOf (undefined :: DDWORD)) :: IO DDWORD) + return $ UnicodeSubsetBitfield usbLow' usbHigh' + poke buf info = do + pokeByteOff buf 0 (usbLow info) + pokeByteOff buf (sizeOf (undefined :: DDWORD)) (usbHigh info) + +getLocaleInfoEx :: Maybe String -> LCTYPE -> IO LCData +getLocaleInfoEx locale ty + | ty == lOCALE_FONTSIGNATURE = + getLocaleInfoEx' LCSignatureData localSigCharCount + + | ty .&. lOCALE_RETURN_NUMBER /= 0 = + getLocaleInfoEx' LCNumericData dWORDCharCount + + | otherwise = maybeWith withTString locale $ \c_locale -> + LCTextualData <$> trySized cFuncName (c_GetLocaleInfoEx c_locale ty) + where + cFuncName = "GetLocaleInfoEx" + -- See https://docs.microsoft.com/en-us/windows/win32/api/winnls/nf-winnls-getlocaleinfoex + localSigCharCount = (#size LOCALESIGNATURE) `div` (#size WCHAR) + dWORDCharCount = (#size DWORD) `div` (#size WCHAR) + + getLocaleInfoEx' constructor bufSize = maybeWith withTString locale $ + \c_locale -> do + value <- alloca $ \buf -> do + _ <- failIfZero cFuncName + $ c_GetLocaleInfoEx c_locale ty (castPtr buf) bufSize + peek buf + return $ constructor value + +foreign import WINDOWS_CCONV unsafe "windows.h GetLocaleInfoEx" + c_GetLocaleInfoEx :: LPCWSTR -> LCTYPE -> LPWSTR -> CInt -> IO CInt + setLocaleInfo :: LCID -> LCTYPE -> String -> IO () setLocaleInfo locale ty info = withTString info $ \ c_info -> @@ -101,25 +326,153 @@ type LCMapFlags = DWORD #{enum LCMapFlags, - , lCMAP_BYTEREV = LCMAP_BYTEREV - , lCMAP_FULLWIDTH = LCMAP_FULLWIDTH - , lCMAP_HALFWIDTH = LCMAP_HALFWIDTH - , lCMAP_HIRAGANA = LCMAP_HIRAGANA - , lCMAP_KATAKANA = LCMAP_KATAKANA - , lCMAP_LOWERCASE = LCMAP_LOWERCASE - , lCMAP_SORTKEY = LCMAP_SORTKEY - , lCMAP_UPPERCASE = LCMAP_UPPERCASE - , nORM_IGNORECASE = NORM_IGNORECASE - , nORM_IGNORENONSPACE = NORM_IGNORENONSPACE - , nORM_IGNOREKANATYPE = NORM_IGNOREKANATYPE - , nORM_IGNORESYMBOLS = NORM_IGNORESYMBOLS - , nORM_IGNOREWIDTH = NORM_IGNOREWIDTH - , sORT_STRINGSORT = SORT_STRINGSORT - , lCMAP_LINGUISTIC_CASING = LCMAP_LINGUISTIC_CASING - , lCMAP_SIMPLIFIED_CHINESE = LCMAP_SIMPLIFIED_CHINESE - , lCMAP_TRADITIONAL_CHINESE = LCMAP_TRADITIONAL_CHINESE + , lCMAP_BYTEREV = LCMAP_BYTEREV + , lCMAP_FULLWIDTH = LCMAP_FULLWIDTH + , lCMAP_HALFWIDTH = LCMAP_HALFWIDTH + , lCMAP_HIRAGANA = LCMAP_HIRAGANA + , lCMAP_KATAKANA = LCMAP_KATAKANA + , lCMAP_LINGUISTIC_CASING = LCMAP_LINGUISTIC_CASING + , lCMAP_LOWERCASE = LCMAP_LOWERCASE + , lCMAP_SIMPLIFIED_CHINESE = LCMAP_SIMPLIFIED_CHINESE + , lCMAP_SORTKEY = LCMAP_SORTKEY + , lCMAP_TRADITIONAL_CHINESE = LCMAP_TRADITIONAL_CHINESE + , lCMAP_UPPERCASE = LCMAP_UPPERCASE + , lINGUISTIC_IGNORECASE = LINGUISTIC_IGNORECASE + , lINGUISTIC_IGNOREDIACRITIC = LINGUISTIC_IGNOREDIACRITIC + , nORM_IGNORECASE = NORM_IGNORECASE + , nORM_IGNORENONSPACE = NORM_IGNORENONSPACE + , nORM_IGNOREKANATYPE = NORM_IGNOREKANATYPE + , nORM_IGNORESYMBOLS = NORM_IGNORESYMBOLS + , nORM_IGNOREWIDTH = NORM_IGNOREWIDTH + , nORM_LINGUISTIC_CASING = NORM_LINGUISTIC_CASING + , sORT_STRINGSORT = SORT_STRINGSORT } +data NLSVERSIONINFOEX = NLSVERSIONINFOEX + { dwNLSVersionInfoSize :: DWORD + , dwNLSVersion :: DWORD + , dwDefinedVersion :: DWORD + , dwEffectiveId :: DWORD + , guidCustomVersion :: GUID + } deriving (Eq, Show) + +instance Storable NLSVERSIONINFOEX where + sizeOf = const #{size NLSVERSIONINFOEX} + alignment _ = #alignment NLSVERSIONINFOEX + peek buf = do + dwNLSVersionInfoSize' <- (#peek NLSVERSIONINFOEX, dwNLSVersionInfoSize) buf + dwNLSVersion' <- (#peek NLSVERSIONINFOEX, dwNLSVersion) buf + dwDefinedVersion' <- (#peek NLSVERSIONINFOEX, dwDefinedVersion) buf + dwEffectiveId' <- (#peek NLSVERSIONINFOEX, dwEffectiveId) buf + guidCustomVersion' <- (#peek NLSVERSIONINFOEX, guidCustomVersion) buf + return $ NLSVERSIONINFOEX dwNLSVersionInfoSize' dwNLSVersion' + dwDefinedVersion' dwEffectiveId' guidCustomVersion' + poke buf info = do + (#poke NLSVERSIONINFOEX, dwNLSVersionInfoSize) buf + (dwNLSVersionInfoSize info) + (#poke NLSVERSIONINFOEX, dwNLSVersion) buf (dwNLSVersion info) + (#poke NLSVERSIONINFOEX, dwDefinedVersion) buf (dwDefinedVersion info) + (#poke NLSVERSIONINFOEX, dwEffectiveId) buf (dwEffectiveId info) + (#poke NLSVERSIONINFOEX, guidCustomVersion) buf (guidCustomVersion info) + +-- Based on the `UnpackedUUID` type of package `uuid-types`. +data GUID = GUID + !Word32 + !Word16 + !Word16 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + !Word8 + deriving (Eq) + +instance Show GUID where + show (GUID data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8) = + printf "{%.8x-%.4x-%.4x-%.2x%2x-%.2x%.2x%.2x%.2x%.2x%.2x}" data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8 + +instance Storable GUID where + sizeOf _ = 16 + alignment _ = 4 + peekByteOff p off = GUID + <$> peekByteOff p off + <*> peekByteOff p (off + 4) + <*> peekByteOff p (off + 6) + <*> peekByteOff p (off + 8) + <*> peekByteOff p (off + 9) + <*> peekByteOff p (off + 10) + <*> peekByteOff p (off + 11) + <*> peekByteOff p (off + 12) + <*> peekByteOff p (off + 13) + <*> peekByteOff p (off + 14) + <*> peekByteOff p (off + 15) + pokeByteOff p off (GUID data1 data2 data3 b1 b2 b3 b4 b5 b6 b7 b8) = do + pokeByteOff p off data1 + pokeByteOff p (off + 4) data2 + pokeByteOff p (off + 6) data3 + pokeByteOff p (off + 8) b1 + pokeByteOff p (off + 9) b2 + pokeByteOff p (off + 10) b3 + pokeByteOff p (off + 11) b4 + pokeByteOff p (off + 12) b5 + pokeByteOff p (off + 13) b6 + pokeByteOff p (off + 14) b7 + pokeByteOff p (off + 15) b8 + +getNLSVersionEx :: Maybe String -> IO NLSVERSIONINFOEX +getNLSVersionEx locale = maybeWith withTString locale $ \c_locale -> + with defaultVersionInfo $ \c_versionInfo -> do + failIfFalse_ "GetNLSVersionEx" $ + c_GetNLSVersionEx function c_locale c_versionInfo + peek c_versionInfo + where + function = #{const COMPARE_STRING} + defaultVersionInfo = NLSVERSIONINFOEX + { dwNLSVersionInfoSize = #{size NLSVERSIONINFOEX} + , dwNLSVersion = 0 + , dwDefinedVersion = 0 + , dwEffectiveId = 0 + , guidCustomVersion = GUID 0 0 0 0 0 0 0 0 0 0 0 + } +foreign import WINDOWS_CCONV unsafe "windows.h GetNLSVersionEx" + c_GetNLSVersionEx :: NLS_FUNCTION + -> LPCWSTR + -> Ptr NLSVERSIONINFOEX + -> IO Bool + +lCMapStringEx :: Maybe String + -> LCMapFlags + -> String + -> NLSVERSIONINFOEX + -> IO String +lCMapStringEx locale flags src versionInfo = + maybeWith withTString locale $ \c_locale -> + withTStringLen src $ \(c_src, src_len) -> + with versionInfo $ \c_versionInfo -> do + let c_src_len = fromIntegral src_len + c_func s l = c_LCMapStringEx c_locale + flags + c_src c_src_len + s l + c_versionInfo + nullPtr -- Reserved, must be NULL + 0 -- Reserved, must be 0 + trySized "LCMapStringEx" c_func +foreign import WINDOWS_CCONV unsafe "windows.h LCMapStringEx" + c_LCMapStringEx :: LPCWSTR + -> LCMapFlags + -> LPCWSTR + -> CInt + -> LPWSTR + -> CInt + -> Ptr NLSVERSIONINFOEX + -> LPVOID + -> LPARAM + -> IO CInt + lCMapString :: LCID -> LCMapFlags -> String -> Int -> IO String lCMapString locale flags src dest_size = withTStringLen src $ \ (c_src, src_len) -> @@ -137,9 +490,63 @@ , lCID_SUPPORTED = LCID_SUPPORTED } +isValidLocaleName :: Maybe String -> IO Bool +isValidLocaleName lpLocaleName = + maybeWith withTString lpLocaleName c_IsValidLocaleName +foreign import WINDOWS_CCONV unsafe "windows.h IsValidLocaleName" + c_IsValidLocaleName :: LPCWSTR -> IO Bool + foreign import WINDOWS_CCONV unsafe "windows.h IsValidLocale" isValidLocale :: LCID -> LocaleTestFlags -> IO Bool +type EnumLocalesFlag = DWORD + +-- The following locale enumeration flag constants are excluded from the `enum` +-- list below, for the reason indicated: +-- LOCALE_NEUTRALDATA -- Introduced in Windows 7 but not supported. + +#{enum EnumLocalesFlag, + , lOCALE_ALL = LOCALE_ALL + , lOCALE_ALTERNATE_SORTS = LOCALE_ALTERNATE_SORTS + , lOCALE_REPLACEMENT = LOCALE_REPLACEMENT + , lOCALE_SUPPLEMENTAL = LOCALE_SUPPLEMENTAL + , lOCALE_WINDOWS = LOCALE_WINDOWS + } + +type LOCALE_ENUMPROCEX = LPWSTR -> EnumLocalesFlag -> LPARAM -> IO BOOL +foreign import WINDOWS_CCONV "wrapper" + mkLOCALE_ENUMPROCEX :: LOCALE_ENUMPROCEX -> IO (FunPtr LOCALE_ENUMPROCEX) + +enumSystemLocalesEx :: LOCALE_ENUMPROCEX -> EnumLocalesFlag -> LPARAM -> IO () +enumSystemLocalesEx callback dwFlags lParam = do + c_callback <- mkLOCALE_ENUMPROCEX callback + failIfFalse_ "EnumSystemLocalesEx" $ + c_EnumSystemLocalesEx c_callback dwFlags lParam nullPtr + freeHaskellFunPtr c_callback +foreign import WINDOWS_CCONV safe "windows.h EnumSystemLocalesEx" + c_EnumSystemLocalesEx :: (FunPtr LOCALE_ENUMPROCEX) + -> DWORD + -> LPARAM + -> LPVOID + -> IO Bool + +enumSystemLocalesEx' :: EnumLocalesFlag + -> Maybe Bool + -- ^ Maybe include (or exclude) replacement locales? + -> IO [String] +enumSystemLocalesEx' dwFlags mIsReplacement = do + store <- newIORef [] + let localeEnumProcEx c_locale arg2 _ = do + locale <- peekTString c_locale + case mIsReplacement of + Nothing -> modifyIORef store (locale:) + Just isReplacement -> + when (isReplacement == (arg2 .&. lOCALE_REPLACEMENT /= 0)) $ + modifyIORef store (locale:) + return True + enumSystemLocalesEx localeEnumProcEx dwFlags 0 + reverse <$> readIORef store + foreign import WINDOWS_CCONV unsafe "windows.h IsValidCodePage" isValidCodePage :: CodePage -> IO Bool @@ -149,6 +556,42 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLangID" getUserDefaultLangID :: LANGID +-- #define LOCALE_NAME_INVARIANT L"" +lOCALE_NAME_INVARIANT :: Maybe String +lOCALE_NAME_INVARIANT = Just "" + + -- #define LOCALE_NAME_SYSTEM_DEFAULT L"!x-sys-default-locale" +lOCALE_NAME_SYSTEM_DEFAULT :: Maybe String +lOCALE_NAME_SYSTEM_DEFAULT = Just "!x-sys-default-locale" + + -- #define LOCALE_NAME_USER_DEFAULT NULL +lOCALE_NAME_USER_DEFAULT :: Maybe String +lOCALE_NAME_USER_DEFAULT = Nothing + +getUserDefaultLocaleName :: IO String +getUserDefaultLocaleName = + getDefaultLocaleName "GetUserDefaultLocaleName" c_GetUserDefaultLocaleName +foreign import WINDOWS_CCONV unsafe "windows.h GetUserDefaultLocaleName" + c_GetUserDefaultLocaleName :: LPWSTR -> CInt -> IO CInt + +#{enum CInt, + , lOCALE_NAME_MAX_LENGTH = LOCALE_NAME_MAX_LENGTH + } + +-- |Helper function for use with 'c_GetUserDefaultLocaleName' or +-- 'c_GetSystemDefaultLocaleName'. See 'getUserDefaultLocaleName' and +-- 'getSystemUserDefaultLocaleName'. +getDefaultLocaleName :: String -> (LPWSTR -> CInt -> IO CInt) -> IO String +getDefaultLocaleName cDefaultLocaleFuncName cDefaultLocaleFunc = + withTStringBufferLen maxLength $ \(buf, len) -> do + let c_len = fromIntegral len + c_len' <- failIfZero cDefaultLocaleFuncName $ + cDefaultLocaleFunc buf c_len + let len' = fromIntegral c_len' + peekTStringLen (buf, len' - 1) -- Drop final null character + where + maxLength = fromIntegral lOCALE_NAME_MAX_LENGTH + foreign import WINDOWS_CCONV unsafe "windows.h GetThreadLocale" getThreadLocale :: IO LCID @@ -157,6 +600,12 @@ foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLangID" getSystemDefaultLangID :: LANGID + +getSystemDefaultLocaleName :: IO String +getSystemDefaultLocaleName = + getDefaultLocaleName "GetSystemDefaultLocaleName" c_GetSystemDefaultLocaleName +foreign import WINDOWS_CCONV unsafe "windows.h GetSystemDefaultLocaleName" + c_GetSystemDefaultLocaleName :: LPWSTR -> CInt -> IO CInt foreign import WINDOWS_CCONV unsafe "windows.h GetOEMCP" getOEMCP :: CodePage diff --git a/System/Win32/Time.hsc b/System/Win32/Time.hsc --- a/System/Win32/Time.hsc +++ b/System/Win32/Time.hsc @@ -18,9 +18,12 @@ ----------------------------------------------------------------------------- module System.Win32.Time where -import System.Win32.Types ( DWORD, WORD, LONG, BOOL, failIf, failIf_, HANDLE - , peekTStringLen, LCID, LPTSTR, LPCTSTR, DDWORD - , LARGE_INTEGER, ddwordToDwords, dwordsToDdword ) +import System.Win32.String ( peekTStringLen, withTString ) +import System.Win32.Types ( BOOL, DDWORD, DWORD, HANDLE, LARGE_INTEGER, LCID + , LONG, LPCTSTR, LPCWSTR, LPTSTR, LPWSTR, UINT, WORD + , dwordsToDdword, ddwordToDwords, failIf + , failIfFalse_, failIf_ ) +import System.Win32.Utils ( trySized ) import Control.Monad ( when, liftM3, liftM ) import Data.Word ( Word8 ) @@ -35,6 +38,7 @@ ##include "windows_cconv.h" #include #include "alignment.h" +#include "winnls_compat.h" ---------------------------------------------------------------- -- data types @@ -59,6 +63,8 @@ data TimeZoneId = TzIdUnknown | TzIdStandard | TzIdDaylight deriving (Show, Eq, Ord) +data LASTINPUTINFO = LASTINPUTINFO DWORD deriving (Show) + ---------------------------------------------------------------- -- Instances ---------------------------------------------------------------- @@ -128,6 +134,16 @@ dnam <- peekCWString (plusPtr buf (#offset TIME_ZONE_INFORMATION, DaylightName)) return $ TIME_ZONE_INFORMATION bias snam sdat sbia dnam ddat dbia +instance Storable LASTINPUTINFO where + sizeOf = const (#size LASTINPUTINFO) + alignment = sizeOf + poke buf (LASTINPUTINFO t) = do + (#poke LASTINPUTINFO, cbSize) buf ((#size LASTINPUTINFO) :: UINT) + (#poke LASTINPUTINFO, dwTime) buf t + peek buf = do + t <- (#peek LASTINPUTINFO, dwTime) buf + return $ LASTINPUTINFO t + foreign import WINDOWS_CCONV "windows.h GetSystemTime" c_GetSystemTime :: Ptr SYSTEMTIME -> IO () getSystemTime :: IO SYSTEMTIME @@ -177,6 +193,21 @@ foreign import WINDOWS_CCONV "windows.h GetTickCount" getTickCount :: IO DWORD +foreign import WINDOWS_CCONV unsafe "windows.h GetLastInputInfo" + c_GetLastInputInfo :: Ptr LASTINPUTINFO -> IO Bool +getLastInputInfo :: IO DWORD +getLastInputInfo = + with (LASTINPUTINFO 0) $ \lii_p -> do + failIfFalse_ "GetLastInputInfo" $ c_GetLastInputInfo lii_p + LASTINPUTINFO lii <- peek lii_p + return lii + +getIdleTime :: IO Integer +getIdleTime = do + lii <- getLastInputInfo + now <- getTickCount + return $ fromIntegral $ now - lii + foreign import WINDOWS_CCONV "windows.h SetSystemTimeAdjustment" c_SetSystemTimeAdjustment :: DWORD -> BOOL -> IO BOOL setSystemTimeAdjustment :: Maybe Int -> IO () @@ -303,6 +334,26 @@ , tIME_NOTIMEMARKER = TIME_NOTIMEMARKER , tIME_FORCE24HOURFORMAT= TIME_FORCE24HOURFORMAT } + +getTimeFormatEx :: Maybe String + -> GetTimeFormatFlags + -> Maybe SYSTEMTIME + -> Maybe String + -> IO String +getTimeFormatEx locale flags st fmt = + maybeWith withTString locale $ \c_locale -> + maybeWith with st $ \c_st -> + maybeWith withTString fmt $ \c_fmt -> do + let c_func = c_GetTimeFormatEx c_locale flags c_st c_fmt + trySized "GetTimeFormatEx" c_func +foreign import WINDOWS_CCONV "windows.h GetTimeFormatEx" + c_GetTimeFormatEx :: LPCWSTR + -> GetTimeFormatFlags + -> Ptr SYSTEMTIME + -> LPCWSTR + -> LPWSTR + -> CInt + -> IO CInt foreign import WINDOWS_CCONV "windows.h GetTimeFormatW" c_GetTimeFormat :: LCID -> GetTimeFormatFlags -> Ptr SYSTEMTIME -> LPCTSTR -> LPTSTR -> CInt -> IO CInt diff --git a/System/Win32/Utils.hs b/System/Win32/Utils.hs --- a/System/Win32/Utils.hs +++ b/System/Win32/Utils.hs @@ -10,24 +10,34 @@ Utilities for calling Win32 API -} module System.Win32.Utils - ( try, tryWithoutNull, try' + ( try, tryWithoutNull, trySized, try' -- * Maybe values , maybePtr, ptrToMaybe, maybeNum, numToMaybe , peekMaybe, withMaybe + -- * Format picture translation + , fromDateFormatPicture + , fromTimeFormatPicture ) where + import Control.Monad ( unless ) +import Foreign.C.Types ( CInt ) import Foreign.Marshal.Array ( allocaArray, peekArray ) import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( Ptr, nullPtr ) import Foreign.Storable ( Storable(..) ) -import System.Win32.Types ( failIfZero - , failWith, getLastError, eRROR_INSUFFICIENT_BUFFER ) +import Text.ParserCombinators.ReadP ( ReadP, (<++), between, char, count + , readP_to_S, satisfy ) + + +import System.Win32.String ( LPTSTR, peekTString, peekTStringLen + , withTStringBufferLen ) +import System.Win32.Types ( BOOL, UINT, eRROR_INSUFFICIENT_BUFFER + , failIfZero, failWith, getLastError + , maybeNum, maybePtr, numToMaybe + , ptrToMaybe ) import qualified System.Win32.Types ( try ) -import System.Win32.String ( LPTSTR, peekTString ) -import System.Win32.Types ( BOOL, UINT, maybePtr, ptrToMaybe, maybeNum, numToMaybe ) import System.Win32.Word ( DWORD, PDWORD ) - -- | 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 extend the buffer size and try again. @@ -39,7 +49,7 @@ tryWithoutNull 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 + if r > n then return (Left r) else do str <- peekTString lptstr return (Right str) case e of @@ -56,16 +66,28 @@ unless (err_code == eRROR_INSUFFICIENT_BUFFER) $ failWith loc err_code r <- peek n' - if (r > n) then return (Left r) else do + if r > n then return (Left r) else do str <- peekArray (fromIntegral r) lptstr return (Right str) case e of Left r' -> try' loc f r' Right str -> return str +-- | Support for API calls that return the required size, in characters +-- including a null character, of the buffer when passed a buffer size of zero. +trySized :: String -> (LPTSTR -> CInt -> IO CInt) -> IO String +trySized wh f = do + c_len <- failIfZero wh $ f nullPtr 0 + let len = fromIntegral c_len + withTStringBufferLen len $ \(buf', len') -> do + let c_len' = fromIntegral len' + c_len'' <- failIfZero wh $ f buf' c_len' + let len'' = fromIntegral c_len'' + peekTStringLen (buf', len'' - 1) -- Drop final null character + -- | See also: 'Foreign.Marshal.Utils.maybePeek' function. peekMaybe :: Storable a => Ptr a -> IO (Maybe a) -peekMaybe p = +peekMaybe p = if p == nullPtr then return Nothing else Just `fmap` peek p @@ -74,3 +96,315 @@ withMaybe :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b withMaybe Nothing action = action nullPtr withMaybe (Just x) action = with x action + +-- | Type representing components of a Windows API day, month, year and era +-- format picture. +data DateFormatPicture + = Day + | Day0 -- Padded with zeros + | DayShort + | DayLong + | Month + | Month0 -- Padded with zeros + | MonthShort + | MonthLong + | YearVeryShort -- Year represented only by the last digit + | YearShort + | Year + | Era + | DateOther String + deriving (Eq, Show) + +fromDFP :: DateFormatPicture -> String +fromDFP Day = "%-e" -- No padding +fromDFP Day0 = "%d" -- Padded with zeros +fromDFP DayShort = "%a" -- eg Tue +fromDFP DayLong = "%A" -- eg Tuesday +fromDFP Month = "%-m" -- No padding +fromDFP Month0 = "%m" -- Padded with zeros +fromDFP MonthShort = "%b" -- eg Jan +fromDFP MonthLong = "%B" -- eg January +fromDFP YearVeryShort = "%-y" -- No direct equivalent of a one digit year, so + -- do not distinguish from a short year without + -- padding +fromDFP YearShort = "%y" +fromDFP Year = "%Y" +fromDFP Era = "" -- No equivalent +fromDFP (DateOther cs) = escape cs + +escape :: String -> String +escape [] = [] +escape (c:cs) = escape' c ++ escape cs + where + escape' '%' = "%%" + escape' '\t' = "%t" + escape' '\n' = "%n" + escape' c' = [c'] + +d :: ReadP Char +d = char 'd' + +day :: ReadP DateFormatPicture +day = do + _ <- d + return Day + +day0 :: ReadP DateFormatPicture +day0 = do + _ <- count 2 d + return Day0 + +dayShort :: ReadP DateFormatPicture +dayShort = do + _ <- count 3 d + return DayShort + +dayLong :: ReadP DateFormatPicture +dayLong = do + _ <- count 4 d + return DayLong + +days :: ReadP DateFormatPicture +days = dayLong <++ dayShort <++ day0 <++ day + +bigM :: ReadP Char +bigM = char 'M' + +month :: ReadP DateFormatPicture +month = do + _ <- bigM + return Month + +month0 :: ReadP DateFormatPicture +month0 = do + _ <- count 2 bigM + return Month0 + +monthShort :: ReadP DateFormatPicture +monthShort = do + _ <- count 3 bigM + return MonthShort + +monthLong :: ReadP DateFormatPicture +monthLong = do + _ <- count 4 bigM + return MonthLong + +months :: ReadP DateFormatPicture +months = monthLong <++ monthShort <++ month0 <++ month + +y :: ReadP Char +y = char 'y' + +yearVeryShort :: ReadP DateFormatPicture +yearVeryShort = do + _ <- y + return YearVeryShort + +yearShort :: ReadP DateFormatPicture +yearShort = do + _ <- count 2 y + return YearShort + +year :: ReadP DateFormatPicture +year = do + _ <- count 5 y <++ count 4 y + return Year + +years :: ReadP DateFormatPicture +years = year <++ yearShort <++ yearVeryShort + +g :: ReadP Char +g = char 'g' + +era :: ReadP DateFormatPicture +era = do + _ <- count 2 g <++ count 1 g + return Era + +quote :: ReadP Char +quote = char '\'' + +notQuote :: ReadP Char +notQuote = satisfy (/= '\'') + +escQuote :: ReadP Char +escQuote = do + _ <- count 2 quote + return '\'' + +quotedChars :: ReadP String +quotedChars = between quote quote $ greedy (escQuote <++ notQuote) + +-- | Although not documented at +-- https://docs.microsoft.com/en-us/windows/win32/intl/day--month--year--and-era-format-pictures +-- the format pictures used by Windows do not require all such characters to be +-- enclosed in single quotation marks. +nonDateSpecial :: ReadP Char +nonDateSpecial = satisfy (\c -> c `notElem` ['d', 'M', 'y', 'g', '\'']) + +nonDateSpecials :: ReadP String +nonDateSpecials = greedy1 nonDateSpecial + +dateOther :: ReadP DateFormatPicture +dateOther = do + chars <- greedy1 (nonDateSpecials <++ quotedChars) + return $ DateOther $ concat chars + +datePicture :: ReadP [DateFormatPicture] +datePicture = greedy (days <++ months <++ years <++ era <++ dateOther) + +-- | Type representing components of a Windows API hours, minute, and second +-- format picture. +data TimeFormatPicture + = Hours12 + | Hours012 -- Padded with zeros + | Hours24 + | Hours024 -- Padded with zeros + | Minutes + | Minutes0 -- Padded with zeros + | Seconds + | Seconds0 -- Padded with zeros + | TimeMarkerShort -- One-character time marker string, eg "A" and "P" + | TimeMarker -- Multi-character time marker string, eg "AM" and "PM" + | TimeOther String + deriving (Eq, Show) + +fromTFP :: TimeFormatPicture -> String +fromTFP Hours12 = "%-l" -- No padding +fromTFP Hours012 = "%I" -- Padded with zeros +fromTFP Hours24 = "%-k" -- No padding +fromTFP Hours024 = "%H" -- Padded with zeros +fromTFP Minutes = "%-M" -- No padding +fromTFP Minutes0 = "%M" -- Padded with zeros +fromTFP Seconds = "%-S" -- No padding +fromTFP Seconds0 = "%S" -- Padded with zeros +fromTFP TimeMarkerShort = "%p" -- No direct equivalent, so do not distinguish + -- from TimeMarker +fromTFP TimeMarker = "%p" +fromTFP (TimeOther cs) = escape cs + +h :: ReadP Char +h = char 'h' + +hours12 :: ReadP TimeFormatPicture +hours12 = do + _ <- h + return Hours12 + +hours012 :: ReadP TimeFormatPicture +hours012 = do + _ <- count 2 h + return Hours012 + +bigH :: ReadP Char +bigH = char 'H' + +hours24 :: ReadP TimeFormatPicture +hours24 = do + _ <- bigH + return Hours24 + +hours024 :: ReadP TimeFormatPicture +hours024 = do + _ <- count 2 bigH + return Hours024 + +hours :: ReadP TimeFormatPicture +hours = hours012 <++ hours12 <++ hours024 <++ hours24 + +m :: ReadP Char +m = char 'm' + +minute :: ReadP TimeFormatPicture +minute = do + _ <- m + return Minutes + +minute0 :: ReadP TimeFormatPicture +minute0 = do + _ <- count 2 m + return Minutes0 + +minutes :: ReadP TimeFormatPicture +minutes = minute0 <++ minute + +s :: ReadP Char +s = char 's' + +second :: ReadP TimeFormatPicture +second = do + _ <- s + return Seconds + +second0 :: ReadP TimeFormatPicture +second0 = do + _ <- count 2 s + return Seconds0 + +seconds :: ReadP TimeFormatPicture +seconds = second0 <++ second + +t :: ReadP Char +t = char 't' + +timeMarkerShort :: ReadP TimeFormatPicture +timeMarkerShort = do + _ <- t + return TimeMarkerShort + +timeMarker :: ReadP TimeFormatPicture +timeMarker = do + _ <- count 2 t + return TimeMarker + +timeMarkers :: ReadP TimeFormatPicture +timeMarkers = timeMarker <++ timeMarkerShort + +-- | Although not documented at +-- https://docs.microsoft.com/en-us/windows/win32/intl/hour--minute--and-second-format-pictures +-- the format pictures used by Windows do not require all such characters to be +-- enclosed in single quotation marks. +nonTimeSpecial :: ReadP Char +nonTimeSpecial = satisfy (\c -> c `notElem` ['h', 'H', 'm', 's', 't', '\'']) + +nonTimeSpecials :: ReadP String +nonTimeSpecials = greedy1 nonTimeSpecial + +timeOther :: ReadP TimeFormatPicture +timeOther = do + chars <- greedy1 (nonTimeSpecials <++ quotedChars) + return $ TimeOther $ concat chars + +timePicture :: ReadP [TimeFormatPicture] +timePicture = greedy (hours <++ minutes <++ seconds <++ timeMarkers <++ + timeOther) + +greedy :: ReadP a -> ReadP [a] +greedy p = greedy1 p <++ return [] + +greedy1 :: ReadP a -> ReadP [a] +greedy1 p = do + first <- p + rest <- greedy p + return (first : rest) + +parseMaybe :: ReadP a -> String -> Maybe a +parseMaybe parser input = + case readP_to_S parser input of + [] -> Nothing + ((result, _):_) -> Just result + +-- | Translate from a Windows API day, month, year, and era format picture to +-- the closest corresponding format string used by +-- 'Data.Time.Format.formatTime'. +fromDateFormatPicture :: String -> Maybe String +fromDateFormatPicture dfp = + fmap (concatMap fromDFP) $ parseMaybe datePicture dfp + +-- | Translate from a Windows API hours, minute, and second format picture to +-- the closest corresponding format string used by +-- 'Data.Time.Format.formatTime'. +fromTimeFormatPicture :: String -> Maybe String +fromTimeFormatPicture tfp = + fmap (concatMap fromTFP) $ parseMaybe timePicture tfp diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,5 +1,5 @@ name: Win32 -version: 2.9.0.0 +version: 2.10.0.0 license: BSD3 license-file: LICENSE author: Alastair Reid, shelarcy, Tamar Christina diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,12 +1,28 @@ # Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32) +## 2.10.0.0 September 2020 + +* Add function `isWindowVisible` +* Add function `getLastInputInfo` +* Add function `getTickCount` +* Add function `getIdleTime` +* Add `enumSystemLocalesEx`, `enumSystemLocalesEx'`, + `getSystemDefaultLocaleName`, `getUserDefaultLocaleName`, `isValidLocaleName`, + `getLocaleInfoEx`, `getTimeFormatEx` and `lCMapStringEx` +* Add `trySized` - similar to `try` but for API calls that return the required + size of the buffer when passed a buffer size of zero. +* Add `fromDateFormatPciture` and `fromTimeFormatPicture`, to translate from + Windows date and time format pictures to format strings used by the `time` + package. +* Renamed fields of `COORD` and `SMALL_RECT` to avoid name clashes. (See #157) + ## 2.9.0.0 June 2020 * `setWindowClosure` now returns the old window closure. -* `defWindowProc` now assumes the data stored in `GWLP\_USERDATA` +* `defWindowProc` now assumes the data stored in `GWLP\_USERDATA` is the window closure (in line with `setWindowClosure` and the supplied C `genericWndProc`) -* `defWindowProc` now frees the window closure +* `defWindowProc` now frees the window closure * `getMessage` and `peekMessage` test for -1 to identify the error condition * Support creating symbolic links without Administrator privilege (See #147) * Support for `winio` the new Windows I/O manager. diff --git a/include/alphablend.h b/include/alphablend.h --- a/include/alphablend.h +++ b/include/alphablend.h @@ -1,6 +1,6 @@ #ifndef _ALPHABLEND_H #define _ALPHABLEND_H -#define WINVER 0x0500 + #include BOOL c_AlphaBlend ( HDC hdcDest, int nXOriginDest, int nYOriginDest, int nWidthDest, int hHeightDest