use monad transformers

7 files changed, 85 insertions, 60 deletions

diff --git a/apps/AddPath.hs b/apps/AddPath.hs
index a32244c..2f1870c 100644
--- a/apps/AddPath.hs
+++ b/apps/AddPath.hs
@@ -7,6 +7,8 @@
 module Main (main) where
 
 import Control.Monad   (void, when)
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
 import Data.List       (union)
 import System.IO.Error (ioError, isDoesNotExistError)
 
@@ -52,16 +54,8 @@ main = execParser parser >>= addPath
 
 addPath :: Options -> IO ()
 addPath options = do
-    oldValue <- Env.query profile varName >>= emptyIfMissing
-    let oldPaths = Env.pathSplit oldValue
-    let newPaths = oldPaths `union` pathsToAdd
-    when (length oldPaths /= length newPaths) $ do
-        let newValue = Env.pathJoin newPaths
-        let promptAnd = if skipPrompt
-            then withoutPrompt
-            else withPrompt $ engraveMessage profile varName oldValue newValue
-        let engrave = Env.engrave profile varName newValue
-        void $ promptAnd engrave
+    ret <- runExceptT $ doAddPath
+    either ioError return ret
   where
     varName = optName options
     pathsToAdd = optPaths options
@@ -73,7 +67,17 @@ addPath options = do
 
     skipPrompt = optYes options
 
-    emptyIfMissing (Left e)
-        | isDoesNotExistError e = return ""
-        | otherwise = ioError e
-    emptyIfMissing (Right s) = return s
+    emptyIfMissing e | isDoesNotExistError e = return ""
+                     | otherwise = throwE e
+
+    doAddPath = do
+        oldValue <- Env.query profile varName `catchE` emptyIfMissing
+        let oldPaths = Env.pathSplit oldValue
+        let newPaths = oldPaths `union` pathsToAdd
+        when (length oldPaths /= length newPaths) $ do
+            let newValue = Env.pathJoin newPaths
+            let promptAnd = if skipPrompt
+                then withoutPrompt
+                else withPrompt $ engraveMessage profile varName oldValue newValue
+            let engrave = Env.engrave profile varName newValue
+            lift $ void $ promptAnd $ runExceptT engrave
diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs
index eb1cb00..02bda10 100644
--- a/apps/RemovePath.hs
+++ b/apps/RemovePath.hs
@@ -7,6 +7,8 @@
 module Main (main) where
 
 import Control.Monad   (void, when)
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
 import Data.List       ((\\))
 import System.IO.Error (ioError, isDoesNotExistError)
 
@@ -52,9 +54,8 @@ main = execParser parser >>= removePath
 
 removePath :: Options -> IO ()
 removePath options = do
-    removePathFrom Env.CurrentUser
-    when forAllUsers $
-        removePathFrom Env.AllUsers
+    ret <- runExceptT $ doRemovePath
+    either ioError return ret
   where
     varName = optName options
     pathsToRemove = optPaths options
@@ -63,13 +64,18 @@ removePath options = do
 
     skipPrompt = optYes options
 
-    removePathFrom profile = do
-        oldValue <- Env.query profile varName
-        either ignoreMissing (doRemovePathFrom profile) oldValue
-
     ignoreMissing e
-        | isDoesNotExistError e = return ()
-        | otherwise = ioError e
+        | isDoesNotExistError e = return ""
+        | otherwise = throwE e
+
+    doRemovePath = do
+        removePathFrom Env.CurrentUser
+        when forAllUsers $
+            removePathFrom Env.AllUsers
+
+    removePathFrom profile = do
+        oldValue <- Env.query profile varName `catchE` ignoreMissing
+        doRemovePathFrom profile oldValue
 
     doRemovePathFrom profile oldValue = do
         let oldPaths = Env.pathSplit oldValue
@@ -80,4 +86,4 @@ removePath options = do
                 then withoutPrompt
                 else withPrompt $ engraveMessage profile varName oldValue newValue
             let engrave = Env.engrave profile varName newValue
-            void $ promptAnd engrave
+            lift $ void $ promptAnd $ runExceptT engrave
diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs
index 96ef7b1..2f3b8f7 100644
--- a/apps/SetEnv.hs
+++ b/apps/SetEnv.hs
@@ -7,6 +7,9 @@
 module Main (main) where
 
 import Control.Monad (void)
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import System.IO.Error (ioError)
 
 import           Options.Applicative
 import qualified Windows.Environment as Env
@@ -48,7 +51,9 @@ main = execParser parser >>= setEnv
         fullDesc <> progDesc "Set environment variables"
 
 setEnv :: Options -> IO ()
-setEnv options = void $ promptAnd engrave
+setEnv options = do
+    ret <- runExceptT $ lift $ void $ promptAnd $ runExceptT engrave
+    either ioError return ret
   where
     varName = optName options
     varValue = optValue options
diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs
index 2ca0997..d56d40c 100644
--- a/apps/UnsetEnv.hs
+++ b/apps/UnsetEnv.hs
@@ -7,6 +7,9 @@
 module Main (main) where
 
 import Control.Monad (void)
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import System.IO.Error (ioError)
 
 import           Options.Applicative
 import qualified Windows.Environment as Env
@@ -43,7 +46,9 @@ main = execParser parser >>= unsetEnv
         fullDesc <> progDesc "Unset environment variables"
 
 unsetEnv :: Options -> IO ()
-unsetEnv options = void $ promptAnd wipe
+unsetEnv options = do
+    ret <- runExceptT $ lift $ void $ promptAnd $ runExceptT wipe
+    either ioError return ret
   where
     varName = optName options
 
diff --git a/src/Windows/Environment.hs b/src/Windows/Environment.hs
index 8597d42..0399d5b 100644
--- a/src/Windows/Environment.hs
+++ b/src/Windows/Environment.hs
@@ -20,9 +20,10 @@ module Windows.Environment
     , pathSplit
     ) where
 
-import Control.Exception (finally)
-import Data.List         (intercalate)
-import Data.List.Split   (splitOn)
+import Control.Monad.Trans.Class  (lift)
+import Control.Monad.Trans.Except (ExceptT(..))
+import Data.List                  (intercalate)
+import Data.List.Split            (splitOn)
 
 import qualified Windows.Registry as Registry
 import           Windows.Utils    (notifyEnvironmentUpdate)
@@ -44,18 +45,20 @@ profileKeyPath AllUsers    = Registry.KeyPath Registry.LocalMachine
 type VarName  = String
 type VarValue = String
 
-query :: Profile -> VarName -> IO (Either IOError VarValue)
+query :: Profile -> VarName -> ExceptT IOError IO VarValue
 query profile name = Registry.getExpandedString (profileKeyPath profile) name
 
-engrave :: Profile -> VarName -> VarValue -> IO (Either IOError ())
-engrave profile name value = finally doEngrave notifyEnvironmentUpdate
-  where
-    doEngrave = Registry.setStringPreserveType (profileKeyPath profile) name value
+engrave :: Profile -> VarName -> VarValue -> ExceptT IOError IO ()
+engrave profile name value = do
+    ret <- Registry.setStringPreserveType (profileKeyPath profile) name value
+    lift notifyEnvironmentUpdate
+    return ret
 
-wipe :: Profile -> VarName -> IO (Either IOError ())
-wipe profile name = finally doWipe notifyEnvironmentUpdate
-  where
-    doWipe = Registry.deleteValue (profileKeyPath profile) name
+wipe :: Profile -> VarName -> ExceptT IOError IO ()
+wipe profile name = do
+    ret <- Registry.deleteValue (profileKeyPath profile) name
+    lift notifyEnvironmentUpdate
+    return ret
 
 pathSep :: VarValue
 pathSep = ";"
diff --git a/src/Windows/Registry.hs b/src/Windows/Registry.hs
index c0ead17..5203fb8 100644
--- a/src/Windows/Registry.hs
+++ b/src/Windows/Registry.hs
@@ -6,8 +6,6 @@
 --
 -- Low-level utility functions for reading and writing registry values.
 
-{-# OPTIONS_GHC -XTupleSections #-}
-
 module Windows.Registry
     ( IsKeyPath(..)
     , RootKey(..)
@@ -45,6 +43,7 @@ import           Data.Tuple            (swap)
 import qualified Data.Text             as T
 import           Data.Text.Encoding    (decodeUtf16LE, encodeUtf16LE)
 import           Control.Exception     (bracket)
+import           Control.Monad.Trans.Except (ExceptT(..), catchE, throwE)
 import           Foreign.ForeignPtr    (withForeignPtr)
 import           Foreign.Marshal.Alloc (alloca, allocaBytes)
 import           Foreign.Marshal.Array (peekArray, pokeArray)
@@ -138,10 +137,10 @@ decodeString (_, bytes) = T.unpack dropLastZero
                  | T.last text == '\0' = T.init text
                  | otherwise = text
 
-openCloseCatch :: IsKeyPath a => a -> (Handle -> IO b) -> IO (Either IOError b)
-openCloseCatch keyPath f = catchIOError (fmap Right openClose) $ return . Left
+openCloseCatch :: IsKeyPath a => a -> (Handle -> IO b) -> ExceptT IOError IO b
+openCloseCatch keyPath f = ExceptT $ catchIOError (openApplyClose >>= return . Right) $ return . Left
   where
-    openClose = bracket (openUnsafe keyPath) close f
+    openApplyClose = bracket (openUnsafe keyPath) close f
 
 foreign import ccall unsafe "Windows.h RegQueryValueExW"
     c_RegQueryValueEx :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPDWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode
@@ -152,7 +151,7 @@ foreign import ccall unsafe "Windows.h RegSetValueExW"
 foreign import ccall unsafe "Windows.h RegGetValueW"
     c_RegGetValue :: WinAPI.PKEY -> WinAPI.LPCTSTR -> WinAPI.LPCTSTR -> WinAPI.DWORD -> WinAPI.LPDWORD -> WinAPI.LPBYTE -> WinAPI.LPDWORD -> IO WinAPI.ErrCode
 
-queryValue :: IsKeyPath a => a -> ValueName -> IO (Either IOError ValueData)
+queryValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueData
 queryValue keyPath valueName =
     openCloseCatch keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -170,7 +169,7 @@ queryValue keyPath valueName =
                 valueType <- toEnum . fromIntegral <$> peek valueTypePtr
                 return (valueType, buffer)
 
-queryType :: IsKeyPath a => a -> ValueName -> IO (Either IOError ValueType)
+queryType :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ValueType
 queryType keyPath valueName =
     openCloseCatch keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -209,7 +208,7 @@ getValueFlagsTable =
     , (DoNotExpand,    0x10000000)
     ]
 
-getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> IO (Either IOError ValueData)
+getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueData
 getValue keyPath valueName flags =
     openCloseCatch keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -230,7 +229,7 @@ getValue keyPath valueName flags =
   where
     rawFlags = fromIntegral $ foldr (.|.) 0 $ map fromEnum flags
 
-getType :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> IO (Either IOError ValueType)
+getType :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueType
 getType keyPath valueName flags =
     openCloseCatch keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -243,12 +242,12 @@ getType keyPath valueName flags =
   where
     rawFlags = fromIntegral $ foldr (.|.) 0 $ map fromEnum $ DoNotExpand : flags
 
-getExpandedString :: IsKeyPath a => a -> ValueName -> IO (Either IOError String)
+getExpandedString :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String
 getExpandedString keyPath valueName = do
     valueData <- getValue keyPath valueName [RestrictString, RestrictExpandableString]
-    return $ fmap decodeString valueData
+    return $ decodeString valueData
 
-setValue :: IsKeyPath a => a -> ValueName -> ValueData -> IO (Either IOError ())
+setValue :: IsKeyPath a => a -> ValueName -> ValueData -> ExceptT IOError IO ()
 setValue keyPath valueName (valueType, valueData) =
     openCloseCatch keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -262,24 +261,23 @@ setValue keyPath valueName (valueType, valueData) =
     buffer = B.unpack valueData
     bufferSize = B.length valueData
 
-setString :: IsKeyPath a => a -> ValueName -> String -> IO (Either IOError ())
+setString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO ()
 setString keyPath valueName valueData =
     setValue keyPath valueName (TypeString, encodeString valueData)
 
-setExpandableString :: IsKeyPath a => a -> ValueName -> String -> IO (Either IOError ())
+setExpandableString :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO ()
 setExpandableString keyPath valueName valueData =
     setValue keyPath valueName (TypeExpandableString, encodeString valueData)
 
-setStringPreserveType :: IsKeyPath a => a -> ValueName -> String -> IO (Either IOError ())
+setStringPreserveType :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO ()
 setStringPreserveType keyPath valueName valueData = do
-    valueType <- stringIfMissing <$> getType keyPath valueName [RestrictString, RestrictExpandableString]
-    either (return . Left) (setValue keyPath valueName . (, encodeString valueData)) valueType
+    valueType <- getType keyPath valueName [RestrictString, RestrictExpandableString] `catchE` stringByDefault
+    setValue keyPath valueName (valueType, encodeString valueData)
   where
-    stringIfMissing (Left e) | isDoesNotExistError e = Right TypeString
-                             | otherwise = Left e
-    stringIfMissing (Right x) = Right x
+    stringByDefault e | isDoesNotExistError e = return TypeString
+                      | otherwise = throwE e
 
-deleteValue :: IsKeyPath a => a -> ValueName -> IO (Either IOError ())
+deleteValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ()
 deleteValue keyPath valueName =
     openCloseCatch keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
diff --git a/windows-env.cabal b/windows-env.cabal
index aee69dc..98f4e3d 100644
--- a/windows-env.cabal
+++ b/windows-env.cabal
@@ -18,7 +18,7 @@ library
   exposed-modules:     Windows.Environment
   other-modules:       Windows.Registry, Windows.Utils
   ghc-options:         -Wall -Werror
-  build-depends:       base, bytestring, split, text, Win32
+  build-depends:       base, bytestring, split, text, transformers, Win32
   default-language:    Haskell2010
 
 executable addpath
@@ -28,6 +28,7 @@ executable addpath
   ghc-options:         -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , optparse-applicative
+                     , transformers
                      , windows-env
   default-language:    Haskell2010
 
@@ -48,6 +49,7 @@ executable delpath
   ghc-options:         -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , optparse-applicative
+                     , transformers
                      , windows-env
   default-language:    Haskell2010
 
@@ -58,6 +60,7 @@ executable setenv
   ghc-options:         -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , optparse-applicative
+                     , transformers
                      , windows-env
   default-language:    Haskell2010
 
@@ -68,6 +71,7 @@ executable delenv
   ghc-options:         -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , optparse-applicative
+                     , transformers
                      , windows-env
   default-language:    Haskell2010