refactoring

12 files changed, 201 insertions, 153 deletions

diff --git a/apps/AddPath.hs b/apps/AddPath.hs
index 9c6c245..6103d1d 100644
--- a/apps/AddPath.hs
+++ b/apps/AddPath.hs
@@ -6,19 +6,22 @@
 
 module Main (main) where
 
-import Control.Monad (when)
+import Control.Monad (void, when)
 import Data.List     (union)
 import Data.Maybe    (fromMaybe)
+import Text.Printf   (printf)
 
 import Options.Applicative
 
 import qualified Environment
 
+import qualified Utils
+
 data Options = Options
-    { optName   :: String
+    { optName   :: Environment.VarName
     , optYes    :: Bool
     , optGlobal :: Bool
-    , optPaths  :: [String]
+    , optPaths  :: [Environment.VarValue]
     } deriving (Eq, Show)
 
 options :: Parser Options
@@ -49,24 +52,23 @@ main = execParser parser >>= addPath
 
 addPath :: Options -> IO ()
 addPath options = do
-    oldValue <- query
+    oldValue <- Environment.query profile varName
     let oldPaths = Environment.pathSplit $ fromMaybe "" oldValue
     let newPaths = union oldPaths pathsToAdd
     when (length oldPaths /= length newPaths) $ do
         let newValue = Environment.pathJoin newPaths
-        engrave newValue
+        let promptBanner = Utils.engraveBanner profile varName oldValue newValue
+        void $ prompt promptBanner $ Environment.engrave profile varName newValue
   where
     varName = optName options
     pathsToAdd = optPaths options
 
     forAllUsers = optGlobal options
-    env = if forAllUsers
+    profile = if forAllUsers
         then Environment.AllUsers
         else Environment.CurrentUser
 
-    query = Environment.query env varName
-
     skipPrompt = optYes options
-    engrave value = if skipPrompt
-        then Environment.engrave       env varName value
-        else Environment.engravePrompt env varName value >> return ()
+    prompt = if skipPrompt
+        then const Utils.withoutPrompt
+        else Utils.withPrompt
diff --git a/apps/FixNtSymbolPath.hs b/apps/FixNtSymbolPath.hs
index 14d0861..3788381 100644
--- a/apps/FixNtSymbolPath.hs
+++ b/apps/FixNtSymbolPath.hs
@@ -16,6 +16,8 @@ import Options.Applicative
 
 import qualified Environment
 
+import qualified Utils
+
 data Options = Options
     { optYes    :: Bool
     , optGlobal :: Bool
@@ -64,30 +66,29 @@ getLocalDirs = do
 
 fixNtSymbolPath :: Options -> IO ()
 fixNtSymbolPath options = do
-    oldValue <- query
+    oldValue <- Environment.query profile varName
     let oldPaths = Environment.pathSplit $ fromMaybe "" oldValue
     localDirs <- getLocalDirs
     let remoteDirs = toRemoteDirs localDirs
     let newPaths = union oldPaths $ dirPaths remoteDirs
     when (length oldPaths /= length newPaths) $ do
         let newValue = Environment.pathJoin newPaths
-        confirmed <- engrave newValue
+        let promptBanner = Utils.engraveBanner profile varName oldValue newValue
+        confirmed <- prompt promptBanner $ Environment.engrave profile varName newValue
         when confirmed $
             createDirs localDirs
   where
     varName = "_NT_SYMBOL_PATH"
 
     forAllUsers = optGlobal options
-    env = if forAllUsers
+    profile = if forAllUsers
         then Environment.AllUsers
         else Environment.CurrentUser
 
-    query = Environment.query env varName
-
     skipPrompt = optYes options
-    engrave value = if skipPrompt
-        then Environment.engrave       env varName value >> return True
-        else Environment.engravePrompt env varName value
+    prompt = if skipPrompt
+        then const Utils.withoutPrompt
+        else Utils.withPrompt
 
 main :: IO ()
 main = execParser parser >>= fixNtSymbolPath
diff --git a/apps/ListPath.hs b/apps/ListPath.hs
index e0cbefe..ace3ede 100644
--- a/apps/ListPath.hs
+++ b/apps/ListPath.hs
@@ -16,7 +16,7 @@ import Options.Applicative
 import qualified Environment
 
 data Options = Options
-    { optName :: String
+    { optName :: Environment.VarName
     } deriving (Eq, Show)
 
 options :: Parser Options
diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs
index 21b4ac6..a594ecd 100644
--- a/apps/RemovePath.hs
+++ b/apps/RemovePath.hs
@@ -6,7 +6,7 @@
 
 module Main (main) where
 
-import Control.Monad (when)
+import Control.Monad (void, when)
 import Data.List     ((\\))
 import Data.Maybe    (fromJust, isJust)
 
@@ -14,11 +14,13 @@ import Options.Applicative
 
 import qualified Environment
 
+import qualified Utils
+
 data Options = Options
-    { optName   :: String
+    { optName   :: Environment.VarName
     , optYes    :: Bool
     , optGlobal :: Bool
-    , optPaths  :: [String]
+    , optPaths  :: [Environment.VarValue]
     } deriving (Eq, Show)
 
 options = Options
@@ -57,16 +59,17 @@ removePath options = do
 
     forAllUsers = optGlobal options
 
-    removePathFrom env = do
-        oldValue <- Environment.query env varName
+    removePathFrom profile = do
+        oldValue <- Environment.query profile varName
         when (isJust oldValue) $ do
             let oldPaths = Environment.pathSplit $ fromJust oldValue
             let newPaths = oldPaths \\ pathsToRemove
             when (length oldPaths /= length newPaths) $ do
                 let newValue = Environment.pathJoin newPaths
-                engrave env newValue
+                let promptBanner = Utils.engraveBanner profile varName oldValue newValue
+                void $ prompt promptBanner $ Environment.engrave profile varName newValue
 
     skipPrompt = optYes options
-    engrave env value = if skipPrompt
-        then Environment.engrave       env varName value
-        else Environment.engravePrompt env varName value >> return ()
+    prompt = if skipPrompt
+        then const Utils.withoutPrompt
+        else Utils.withPrompt
diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs
index 3b88e7c..0b95176 100644
--- a/apps/SetEnv.hs
+++ b/apps/SetEnv.hs
@@ -6,15 +6,19 @@
 
 module Main (main) where
 
+import Control.Monad (void)
+
 import Options.Applicative hiding (value)
 
 import qualified Environment
 
+import qualified Utils
+
 data Options = Options
     { optYes    :: Bool
     , optGlobal :: Bool
-    , optName   :: String
-    , optValue  :: String
+    , optName   :: Environment.VarName
+    , optValue  :: Environment.VarValue
     } deriving (Eq, Show)
 
 options :: Parser Options
@@ -44,17 +48,19 @@ main = execParser parser >>= setEnv
         fullDesc <> progDesc "Set environment variable"
 
 setEnv :: Options -> IO ()
-setEnv options = engrave varValue
+setEnv options = void $ prompt confirmationBanner $ Environment.engrave profile varName varValue
   where
+    confirmationBanner = Utils.engraveBanner profile varName Nothing varValue
+
     varName = optName options
     varValue = optValue options
 
     forAllUsers = optGlobal options
-    env = if forAllUsers
+    profile = if forAllUsers
         then Environment.AllUsers
         else Environment.CurrentUser
 
     skipPrompt = optYes options
-    engrave value = if skipPrompt
-        then Environment.engrave       env varName value
-        else Environment.engravePrompt env varName value >> return ()
+    prompt = if skipPrompt
+        then const Utils.withoutPrompt
+        else Utils.withPrompt
diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs
index e4cbeac..b0ed96a 100644
--- a/apps/UnsetEnv.hs
+++ b/apps/UnsetEnv.hs
@@ -6,14 +6,18 @@
 
 module Main (main) where
 
+import Control.Monad (void)
+
 import Options.Applicative
 
 import qualified Environment
 
+import qualified Utils
+
 data Options = Options
     { optYes    :: Bool
     , optGlobal :: Bool
-    , optName   :: String
+    , optName   :: Environment.VarName
     } deriving (Eq, Show)
 
 options :: Parser Options
@@ -39,16 +43,18 @@ main = execParser parser >>= unsetEnv
         fullDesc <> progDesc "Unset environment variable"
 
 unsetEnv :: Options -> IO ()
-unsetEnv options = wipe
+unsetEnv options = void $ prompt confirmationBanner $ Environment.wipe profile varName
   where
+    confirmationBanner = Utils.wipeBanner profile varName
+
     varName = optName options
 
     forAllUsers = optGlobal options
-    env = if forAllUsers
+    profile = if forAllUsers
         then Environment.AllUsers
         else Environment.CurrentUser
 
     skipPrompt = optYes options
-    wipe = if skipPrompt
-        then Environment.wipe       env varName
-        else Environment.wipePrompt env varName >> return ()
+    prompt = if skipPrompt
+        then const Utils.withoutPrompt
+        else Utils.withPrompt
diff --git a/apps/Utils.hs b/apps/Utils.hs
new file mode 100644
index 0000000..28309d4
--- /dev/null
+++ b/apps/Utils.hs
@@ -0,0 +1,66 @@
+{-
+ - Copyright 2015 Egor Tensin <Egor.Tensin@gmail.com>
+ - This file is licensed under the terms of the MIT License.
+ - See LICENSE.txt for details.
+-}
+
+module Utils
+    ( withPrompt
+    , withoutPrompt
+
+    , engraveBanner
+    , wipeBanner
+    ) where
+
+import Control.Monad (liftM, void, when)
+import Data.Maybe    (fromJust, isJust)
+import Data.Char     (toLower)
+import System.IO     (hFlush, stdout)
+import Text.Printf   (printf)
+
+import Environment   (Profile, profileKeyPath, VarName, VarValue)
+
+prompt :: String -> IO String
+prompt banner = do
+    putStr banner
+    hFlush stdout
+    getLine
+
+promptYesNo :: String -> IO Bool
+promptYesNo banner = do
+    response <- liftM (map toLower) $ prompt banner
+    if response `elem` yeses
+        then return True
+        else if response `elem` noes
+            then return False
+            else promptToContinue
+  where
+    yeses = ["y", "yes"]
+    noes = ["n", "no"]
+    
+promptToContinue :: IO Bool
+promptToContinue = promptYesNo "Continue? (y/n) "
+
+withPrompt :: String -> IO a -> IO Bool
+withPrompt banner m = do
+    putStr banner
+    hFlush stdout
+    agreed <- promptToContinue
+    when agreed $ void m
+    return agreed
+
+withoutPrompt :: IO a -> IO Bool
+withoutPrompt m = m >> return True
+
+engraveBanner :: Profile -> VarName -> Maybe VarValue -> VarValue -> String
+engraveBanner profile name oldValue newValue =
+    header ++ values
+  where
+    header = printf "Saving variable '%s' to '%s'...\n" name (profileKeyPath profile)
+    values = if isJust oldValue
+        then printf "\tOld value: %s\n\tNew value: %s\n" (fromJust oldValue) newValue
+        else printf "\tValue: %s\n" newValue
+
+wipeBanner :: Profile -> VarName -> String
+wipeBanner profile name =
+    printf "Deleting variable '%s' from '%s'...\n" name (profileKeyPath profile)
diff --git a/src/Environment.hs b/src/Environment.hs
index 68a3917..f370de4 100644
--- a/src/Environment.hs
+++ b/src/Environment.hs
@@ -5,116 +5,84 @@
 -}
 
 module Environment
-    ( RegistryLocation(..)
+    ( Profile(..)
+    , profileKeyPath
+
+    , VarName
+    , VarValue
     , query
     , engrave
-    , engravePrompt
     , wipe
-    , wipePrompt
 
     , pathJoin
     , pathSplit
     ) where
 
-import Control.Monad   (when)
 import Data.List       (intercalate)
 import Data.List.Split (splitOn)
-import Data.Maybe      (fromJust, isJust)
 import System.IO.Error (catchIOError, isDoesNotExistError)
 
-import qualified Graphics.Win32.GDI.Types as WinAPI
-import qualified Graphics.Win32.Message   as WinAPI
-import qualified System.Win32.Types       as WinAPI
-
 import qualified Registry
-import qualified Utils (promptToContinue)
+import           WindowsUtils (notifyEnvironmentUpdate)
 
-data RegistryLocation
-    = CurrentUser
-    | AllUsers
-    deriving (Eq, Show)
+data Profile = CurrentUser
+             | AllUsers
+             deriving (Eq, Show)
 
-subKeyPath :: RegistryLocation -> Registry.KeyPath
-subKeyPath CurrentUser =
-    Registry.keyPathFromString "Environment"
-subKeyPath AllUsers =
-    Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment"
+profileRootKey :: Profile -> Registry.RootKey
+profileRootKey CurrentUser = Registry.CurrentUser
+profileRootKey AllUsers    = Registry.LocalMachine
 
-rootKey :: RegistryLocation -> Registry.RootKey
-rootKey CurrentUser = Registry.CurrentUser
-rootKey AllUsers    = Registry.LocalMachine
+profileRootKeyPath :: Profile -> Registry.KeyPath
+profileRootKeyPath = Registry.rootKeyPath . profileRootKey
 
-openRootKey :: RegistryLocation -> Registry.KeyHandle
-openRootKey = Registry.openRootKey . rootKey
+profileSubKeyPath :: Profile -> Registry.KeyPath
+profileSubKeyPath CurrentUser =
+    Registry.keyPathFromString "Environment"
+profileSubKeyPath AllUsers =
+    Registry.keyPathFromString "SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment"
 
-openRegistryKey :: RegistryLocation -> IO Registry.KeyHandle
-openRegistryKey env = Registry.openSubKey (openRootKey env) (subKeyPath env)
+profileKeyPath :: Profile -> Registry.KeyPath
+profileKeyPath profile = Registry.keyPathJoin
+    [ profileRootKeyPath profile
+    , profileSubKeyPath  profile
+    ]
 
-registryKeyPath :: RegistryLocation -> Registry.KeyPath
-registryKeyPath env = Registry.keyPathJoin [Registry.rootKeyPath $ rootKey env, subKeyPath env]
+openRootProfileKey :: Profile -> Registry.KeyHandle
+openRootProfileKey = Registry.openRootKey . profileRootKey
 
-foreign import ccall "SendNotifyMessageW"
-    c_SendNotifyMessage :: WinAPI.HWND -> WinAPI.WindowMessage -> WinAPI.WPARAM -> WinAPI.LPARAM -> IO WinAPI.LRESULT
+openProfileKey :: Profile -> IO Registry.KeyHandle
+openProfileKey profile = Registry.openSubKey (openRootProfileKey profile) (profileSubKeyPath profile)
 
-notifyEnvUpdate :: IO ()
-notifyEnvUpdate =
-    WinAPI.withTString "Environment" $ \lparamPtr -> do
-        let wparam = 0
-        let lparam = fromIntegral $ WinAPI.castPtrToUINTPtr lparamPtr
-        _ <- c_SendNotifyMessage allWindows messageCode wparam lparam
-        return ()
-  where
-    messageCode = WinAPI.wM_WININICHANGE
-    hWND_BROADCAST = WinAPI.castUINTPtrToPtr 0xffff
-    allWindows = hWND_BROADCAST
+type VarName  = Registry.ValueName
+type VarValue = Registry.ValueData
 
-query :: RegistryLocation -> Registry.ValueName -> IO (Maybe Registry.ValueData)
-query env name = do
-    keyHandle <- openRegistryKey env
+query :: Profile -> VarName -> IO (Maybe VarValue)
+query profile name = do
+    keyHandle <- openProfileKey profile
     catchIOError (Registry.getString keyHandle name >>= return . Just) emptyIfDoesNotExist
   where
     emptyIfDoesNotExist e = if isDoesNotExistError e then return Nothing else ioError e
 
-engrave :: RegistryLocation -> Registry.ValueName -> Registry.ValueData -> IO ()
-engrave env name value = do
-    keyHandle <- openRegistryKey env
+engrave :: Profile -> VarName -> VarValue -> IO ()
+engrave profile name value = do
+    keyHandle <- openProfileKey profile
     Registry.setString keyHandle name value
-    notifyEnvUpdate
-
-engravePrompt :: RegistryLocation -> Registry.ValueName -> Registry.ValueData -> IO Bool
-engravePrompt env name value = do
-    putStrLn $ "Saving variable '" ++ name ++ "' to '" ++ registryKeyPath env ++ "'..."
-    oldValue <- query env name
-    if (isJust oldValue)
-        then do
-            putStrLn $ "\tOld value: " ++ fromJust oldValue
-            putStrLn $ "\tNew value: " ++ value
-        else do
-            putStrLn $ "\tValue: " ++ value
-    agreed <- Utils.promptToContinue
-    when agreed $ engrave env name value
-    return agreed
-
-wipe :: RegistryLocation -> Registry.ValueName -> IO ()
-wipe env name = do
-    keyHandle <- openRegistryKey env
+    notifyEnvironmentUpdate
+
+wipe :: Profile -> VarName -> IO ()
+wipe profile name = do
+    keyHandle <- openProfileKey profile
     catchIOError (Registry.delValue keyHandle name) ignoreIfDoesNotExist
-    notifyEnvUpdate
+    notifyEnvironmentUpdate
   where
     ignoreIfDoesNotExist e = if isDoesNotExistError e then return () else ioError e
 
-wipePrompt :: RegistryLocation -> Registry.ValueName -> IO Bool
-wipePrompt env name = do
-    putStrLn $ "Deleting variable '" ++ name ++ "' from '" ++ registryKeyPath env ++ "'..."
-    agreed <- Utils.promptToContinue
-    when agreed $ wipe env name
-    return agreed
-
-pathSep :: String
+pathSep :: VarValue
 pathSep = ";"
 
-pathSplit :: String -> [String]
+pathSplit :: VarValue -> [VarValue]
 pathSplit = filter (not . null) . splitOn pathSep
 
-pathJoin :: [String] -> String
+pathJoin :: [VarValue] -> VarValue
 pathJoin = intercalate pathSep . filter (not . null)
diff --git a/src/Registry.hs b/src/Registry.hs
index 4a7c593..48d69f0 100644
--- a/src/Registry.hs
+++ b/src/Registry.hs
@@ -14,8 +14,8 @@ module Registry
     , openSubKey
 
     , RootKey(..)
-    , openRootKey
     , rootKeyPath
+    , openRootKey
 
     , ValueName
     , delValue
diff --git a/src/Utils.hs b/src/Utils.hs
deleted file mode 100644
index 143696b..0000000
--- a/src/Utils.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-
- - Copyright 2015 Egor Tensin <Egor.Tensin@gmail.com>
- - This file is licensed under the terms of the MIT License.
- - See LICENSE.txt for details.
--}
-
-module Utils where
-
-import Control.Monad (liftM)
-import Data.Char     (toLower)
-import System.IO     (hFlush, stdout)
-
-prompt :: String -> IO String
-prompt banner = do
-    putStr banner
-    hFlush stdout
-    getLine
-
-promptYesNo :: String -> IO Bool
-promptYesNo banner = do
-    response <- liftM (map toLower) $ prompt banner
-    if response `elem` yeses
-        then return True
-        else if response `elem` noes
-            then return False
-            else promptToContinue
-  where
-    yeses = ["y", "yes"]
-    noes = ["n", "no"]
-
-promptToContinue :: IO Bool
-promptToContinue = promptYesNo "Continue? (y/n) "
diff --git a/src/WindowsUtils.hs b/src/WindowsUtils.hs
new file mode 100644
index 0000000..6fa1f0e
--- /dev/null
+++ b/src/WindowsUtils.hs
@@ -0,0 +1,28 @@
+{-
+ - Copyright 2016 Egor Tensin <Egor.Tensin@gmail.com>
+ - This file is licensed under the terms of the MIT License.
+ - See LICENSE.txt for details.
+-}
+
+module WindowsUtils
+    ( notifyEnvironmentUpdate
+    ) where
+
+import qualified Graphics.Win32.GDI.Types as WinAPI
+import qualified Graphics.Win32.Message   as WinAPI
+import qualified System.Win32.Types       as WinAPI
+
+foreign import ccall "SendNotifyMessageW"
+    c_SendNotifyMessage :: WinAPI.HWND -> WinAPI.WindowMessage -> WinAPI.WPARAM -> WinAPI.LPARAM -> IO WinAPI.LRESULT
+
+notifyEnvironmentUpdate :: IO ()
+notifyEnvironmentUpdate =
+    WinAPI.withTString "Environment" $ \lparamPtr -> do
+        let wparam = 0
+        let lparam = fromIntegral $ WinAPI.castPtrToUINTPtr lparamPtr
+        _ <- c_SendNotifyMessage allWindows messageCode wparam lparam
+        return ()
+  where
+    messageCode = WinAPI.wM_WININICHANGE
+    hWND_BROADCAST = WinAPI.castUINTPtrToPtr 0xffff
+    allWindows = hWND_BROADCAST
diff --git a/windows-env.cabal b/windows-env.cabal
index 4293db6..aa0190e 100644
--- a/windows-env.cabal
+++ b/windows-env.cabal
@@ -15,7 +15,7 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Environment, Registry, Utils
+  exposed-modules:     Environment, Registry, WindowsUtils
   ghc-options:         -Wall -Werror
   build-depends:       base, split, Win32
   default-language:    Haskell2010