From 40ffb60f6ee1d748163333aa7bcf75e98b87184f Mon Sep 17 00:00:00 2001
From: Egor Tensin <Egor.Tensin@gmail.com>
Date: Fri, 26 Feb 2016 21:34:32 +0300
Subject: refactoring

---
 RegUtils.hs | 44 +++++++++++++++++++++-----------------------
 1 file changed, 21 insertions(+), 23 deletions(-)

diff --git a/RegUtils.hs b/RegUtils.hs
index ba997a1..eccb6ad 100644
--- a/RegUtils.hs
+++ b/RegUtils.hs
@@ -16,6 +16,7 @@ import Foreign.ForeignPtr ( withForeignPtr )
 import Foreign.Marshal.Alloc ( alloca, allocaBytes )
 import Foreign.Ptr ( castPtr, plusPtr )
 import Foreign.Storable ( peek, poke, sizeOf )
+import Graphics.Win32.Window ( sendMessage )
 import System.IO.Error ( mkIOError, doesNotExistErrorType )
 import System.Win32.Types
 import System.Win32.Registry
@@ -23,25 +24,25 @@ import System.Win32.Registry
 getType :: HKEY -> String -> String -> IO (Maybe RegValueType)
 getType key subKeyPath valueName =
   bracket (regOpenKey key subKeyPath) regCloseKey $ \key ->
-  withForeignPtr key $ \keyPtr ->
-  withTString valueName $ \valueNamePtr ->
-  alloca $ \typePtr -> do
-    ret <- c_RegQueryValueEx keyPtr valueNamePtr nullPtr typePtr nullPtr nullPtr
+  withForeignPtr key $ \p_key ->
+  withTString valueName $ \p_valueName ->
+  alloca $ \p_type -> do
+    ret <- c_RegQueryValueEx p_key p_valueName nullPtr p_type nullPtr nullPtr
     case ret of
       0x0 -> do
-        type' <- peek typePtr
-        return $ Just type'
+        type_ <- peek p_type
+        return $ Just type_
       0x2 -> return Nothing
       _   -> failWith "RegQueryValueEx" ret
 
 getString :: HKEY -> String -> String -> IO String
 getString key subKeyPath valueName =
   bracket (regOpenKey key subKeyPath) regCloseKey $ \key ->
-  withForeignPtr key $ \keyPtr ->
-  withTString valueName $ \valueNamePtr ->
+  withForeignPtr key $ \p_key ->
+  withTString valueName $ \p_valueName ->
   alloca $ \dataSizePtr -> do
     poke dataSizePtr 0
-    ret <- c_RegQueryValueEx keyPtr valueNamePtr nullPtr nullPtr nullPtr dataSizePtr
+    ret <- c_RegQueryValueEx p_key p_valueName nullPtr nullPtr nullPtr dataSizePtr
     case ret of
       0x0 -> do
         dataSize <- peek dataSizePtr
@@ -50,7 +51,7 @@ getString key subKeyPath valueName =
         allocaBytes (fromIntegral newDataSize) $ \dataPtr -> do
           poke (castPtr $ plusPtr dataPtr $ fromIntegral dataSize) '\0'
           failUnlessSuccess "RegQueryValueEx" $
-            c_RegQueryValueEx keyPtr valueNamePtr nullPtr nullPtr dataPtr dataSizePtr
+            c_RegQueryValueEx p_key p_valueName nullPtr nullPtr dataPtr dataSizePtr
           peekTString $ castPtr dataPtr
       0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName)
       _   -> failWith "RegQueryValueEx" ret
@@ -58,31 +59,28 @@ getString key subKeyPath valueName =
 setString :: HKEY -> String -> String -> String -> IO ()
 setString key subKeyPath valueName valueValue =
   bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey ->
-  withTString valueValue $ \ptr -> do
-    type' <- getType key subKeyPath valueName
-    regSetValueEx subKey valueName (fromMaybe rEG_SZ type') ptr $ (length valueValue + 1) * sizeOf (undefined :: TCHAR)
+  withTString valueValue $ \p_valueValue -> do
+    type_ <- getType key subKeyPath valueName
+    regSetValueEx subKey valueName (fromMaybe rEG_SZ type_) p_valueValue $ (length valueValue + 1) * sizeOf (undefined :: TCHAR)
     notifyEnvironmentUpdate
 
-foreign import ccall "BroadcastSystemMessageW"
-  c_BroadcastSystemMessage :: DWORD -> LPDWORD -> UINT -> WPARAM -> LPARAM -> IO LONG
-
 notifyEnvironmentUpdate :: IO ()
 notifyEnvironmentUpdate =
-  withTString "Environment" $ \lparamPtr -> do
-    let wparam = fromIntegral $ castPtrToUINTPtr nullPtr
-    let lparam = fromIntegral $ castPtrToUINTPtr lparamPtr
-    c_BroadcastSystemMessage bSF_POSTMESSAGE nullPtr wM_SETTINGCHANGE wparam lparam
+  withTString "Environment" $ \p_lparam -> do
+    let wparam = 0
+    let lparam = fromIntegral $ castPtrToUINTPtr p_lparam
+    let hwnd = castUINTPtrToPtr 0xffff
+    sendMessage hwnd wM_SETTINGCHANGE wparam lparam
     return ()
       where
-        bSF_POSTMESSAGE = 0x10
         wM_SETTINGCHANGE = 0x1A
 
 delValue :: HKEY -> String -> String -> IO ()
 delValue key subKeyPath valueName =
   bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey ->
   withForeignPtr subKey $ \subKeyPtr ->
-  withTString valueName $ \valueNamePtr -> do
-    ret <- c_RegDeleteValue subKeyPtr valueNamePtr
+  withTString valueName $ \p_valueName -> do
+    ret <- c_RegDeleteValue subKeyPtr p_valueName
     notifyEnvironmentUpdate
     case ret of
       0x0 -> return ()
-- 
cgit v1.2.3