refactoring

The fact whether the registry value was a regular or an expandable
string is now propagated up to the `Environment` module (and even
further to the apps).
This was done to get rid of these weird `setString*` functions (and the
like).
I don't feel like I've came up with the right abstractions yet though,
so there's more work on this to come.

7 files changed, 102 insertions, 91 deletions

diff --git a/app/AddPath.hs b/app/AddPath.hs
index fc8d5de..1993b4a 100644
--- a/app/AddPath.hs
+++ b/app/AddPath.hs
@@ -20,11 +20,11 @@ import Utils.Prompt
 import Utils.PromptMessage
 
 data Options = Options
-    { optName   :: WindowsEnv.VarName
+    { optName    :: WindowsEnv.VarName
     , optYes     :: Bool
     , optGlobal  :: Bool
     , optPrepend :: Bool
-    , optPaths   :: [WindowsEnv.VarValue]
+    , optPaths   :: [String]
     } deriving (Eq, Show)
 
 optionParser :: Parser Options
@@ -62,7 +62,7 @@ addPath :: Options -> IO ()
 addPath options = runExceptT doAddPath >>= either ioError return
   where
     varName = optName options
-    pathsToAdd = optPaths options
+    pathsToAdd = nub $ optPaths options
 
     forAllUsers = optGlobal options
     profile
@@ -72,22 +72,31 @@ addPath options = runExceptT doAddPath >>= either ioError return
     skipPrompt = optYes options
 
     prepend = optPrepend options
-    append xs ys
-        | prepend = ys ++ xs
-        | otherwise = xs ++ ys
+    mergePaths old new
+        | prepend = new ++ old
+        | otherwise = old ++ new
 
     emptyIfMissing e
-        | isDoesNotExistError e = return ""
+        | isDoesNotExistError e = defaultValue
         | otherwise = throwE e
 
+    defaultValue = do
+        expandedPaths <- mapM WindowsEnv.expand pathsToAdd
+        if pathsToAdd == expandedPaths
+            then return $ WindowsEnv.VarValue False ""
+            else return $ WindowsEnv.VarValue True ""
+
     doAddPath = do
         oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing
-        let oldPaths = WindowsEnv.pathSplit oldValue
-        let newPaths = (nub pathsToAdd) \\ oldPaths
+        let oldPaths = WindowsEnv.pathSplit $ show oldValue
+        let newPaths = pathsToAdd \\ oldPaths
         unless (null newPaths) $ do
-            let newValue = WindowsEnv.pathJoin $ append oldPaths newPaths
-            let promptAnd = if skipPrompt
-                then withoutPrompt
-                else withPrompt $ oldNewMessage profile varName oldValue newValue
-            let engrave = WindowsEnv.engrave profile varName newValue
-            void $ promptAnd engrave
+            let newValue = WindowsEnv.VarValue (WindowsEnv.varValueExpandable oldValue) $ WindowsEnv.pathJoin (mergePaths oldPaths newPaths)
+            promptAndEngrave oldValue newValue
+
+    promptAndEngrave oldValue newValue = do
+        let promptAnd = if skipPrompt
+            then withoutPrompt
+            else withPrompt $ oldNewMessage profile varName (show oldValue) (show newValue)
+        let engrave = WindowsEnv.engrave profile varName newValue
+        void $ promptAnd engrave
diff --git a/app/ListPaths.hs b/app/ListPaths.hs
index 4193ad6..8a31cb8 100644
--- a/app/ListPaths.hs
+++ b/app/ListPaths.hs
@@ -22,7 +22,7 @@ import qualified WindowsEnv
 data WhichPaths = All | ExistingOnly | MissingOnly
                 deriving (Eq, Show)
 
-shouldListPath :: WhichPaths -> WindowsEnv.VarValue -> IO Bool
+shouldListPath :: WhichPaths -> String -> IO Bool
 shouldListPath All = return . const True
 shouldListPath ExistingOnly = doesDirectoryExist
 shouldListPath MissingOnly  = fmap not . doesDirectoryExist
@@ -72,7 +72,7 @@ listPaths options = runExceptT doListPaths >>= either ioError return
     query = queryFrom $ optSource options
 
     queryFrom Environment = lift $ fromMaybe "" <$> lookupEnv varName
-    queryFrom (Registry profile) = WindowsEnv.query profile varName
+    queryFrom (Registry profile) = show <$> WindowsEnv.query profile varName
 
     filterPaths = filterM (shouldListPath whichPaths . WindowsEnv.pathExpanded)
 
diff --git a/app/RemovePath.hs b/app/RemovePath.hs
index bc2a076..2d0d47c 100644
--- a/app/RemovePath.hs
+++ b/app/RemovePath.hs
@@ -22,7 +22,7 @@ data Options = Options
     { optName   :: WindowsEnv.VarName
     , optYes    :: Bool
     , optGlobal :: Bool
-    , optPaths  :: [WindowsEnv.VarValue]
+    , optPaths  :: [String]
     } deriving (Eq, Show)
 
 optionParser :: Parser Options
@@ -63,9 +63,15 @@ removePath options = runExceptT doRemovePath >>= either ioError return
     skipPrompt = optYes options
 
     emptyIfMissing e
-        | isDoesNotExistError e = return ""
+        | isDoesNotExistError e = defaultValue
         | otherwise = throwE e
 
+    defaultValue = do
+        expandedPaths <- mapM WindowsEnv.expand pathsToRemove
+        if pathsToRemove == expandedPaths
+            then return $ WindowsEnv.VarValue False ""
+            else return $ WindowsEnv.VarValue True ""
+
     doRemovePath = do
         removePathFrom WindowsEnv.CurrentUser
         when forAllUsers $
@@ -73,12 +79,12 @@ removePath options = runExceptT doRemovePath >>= either ioError return
 
     removePathFrom profile = do
         oldValue <- WindowsEnv.query profile varName `catchE` emptyIfMissing
-        let oldPaths = WindowsEnv.pathSplit oldValue
+        let oldPaths = WindowsEnv.pathSplit $ show oldValue
         let newPaths = filter (flip notElem pathsToRemove) oldPaths
         when (length oldPaths /= length newPaths) $ do
-            let newValue = WindowsEnv.pathJoin newPaths
+            let newValue = WindowsEnv.VarValue (WindowsEnv.varValueExpandable oldValue) (WindowsEnv.pathJoin newPaths)
             let promptAnd = if skipPrompt
                 then withoutPrompt
-                else withPrompt $ oldNewMessage profile varName oldValue newValue
+                else withPrompt $ oldNewMessage profile varName (show oldValue) (show newValue)
             let engrave = WindowsEnv.engrave profile varName newValue
             void $ promptAnd engrave
diff --git a/app/SetEnv.hs b/app/SetEnv.hs
index 5948d3e..bb058d8 100644
--- a/app/SetEnv.hs
+++ b/app/SetEnv.hs
@@ -22,7 +22,7 @@ data Options = Options
     { optYes    :: Bool
     , optGlobal :: Bool
     , optName   :: WindowsEnv.VarName
-    , optValue  :: WindowsEnv.VarValue
+    , optValue  :: String
     } deriving (Eq, Show)
 
 optionParser :: Parser Options
@@ -67,6 +67,6 @@ setEnv options = runExceptT doSetEnv >>= either ioError return
         | skipPrompt = withoutPrompt
         | otherwise  = withPrompt $ newMessage profile varName varValue
 
-    engrave = WindowsEnv.engraveForce profile varName varValue
+    engrave = WindowsEnv.engrave profile varName $ WindowsEnv.VarValue False varValue
 
     doSetEnv = void $ promptAnd engrave
diff --git a/app/Utils/PromptMessage.hs b/app/Utils/PromptMessage.hs
index 37fc1e6..9afffb1 100644
--- a/app/Utils/PromptMessage.hs
+++ b/app/Utils/PromptMessage.hs
@@ -15,7 +15,7 @@ import Text.Printf (printf)
 
 import qualified WindowsEnv
 
-oldNewMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> WindowsEnv.VarValue -> String
+oldNewMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> String -> String -> String
 oldNewMessage profile name oldValue newValue =
     descrMsg ++ oldValueMsg ++ newValueMsg
   where
@@ -24,7 +24,7 @@ oldNewMessage profile name oldValue newValue =
     oldValueMsg = printf "\tOld value: %s\n" oldValue
     newValueMsg = printf "\tNew value: %s\n" newValue
 
-newMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> WindowsEnv.VarValue -> String
+newMessage :: WindowsEnv.Profile -> WindowsEnv.VarName -> String -> String
 newMessage profile name newValue =
     descrMsg ++ newValueMsg
   where
diff --git a/src/WindowsEnv/Environment.hs b/src/WindowsEnv/Environment.hs
index 8060b14..e56f5c9 100644
--- a/src/WindowsEnv/Environment.hs
+++ b/src/WindowsEnv/Environment.hs
@@ -15,11 +15,10 @@ module WindowsEnv.Environment
     , profileKeyPath
 
     , VarName
-    , VarValue
+    , VarValue(..)
 
     , query
     , engrave
-    , engraveForce
     , wipe
 
     , pathJoin
@@ -56,21 +55,33 @@ profileKeyPath AllUsers    = Registry.KeyPath Registry.LocalMachine
     , "Environment"
     ]
 
-type VarName  = String
-type VarValue = String
+type VarName = String
+
+data VarValue = VarValue
+    { varValueExpandable :: Bool
+    , varValueString :: String
+    } deriving (Eq)
+
+instance Show VarValue where
+    show = varValueString
+
+valueFromRegistry :: Registry.StringValue -> VarValue
+valueFromRegistry (valueType, valueData)
+    | valueType == Registry.TypeString = VarValue False valueData
+    | valueType == Registry.TypeExpandableString = VarValue True valueData
+    | otherwise = error "WindowsEnv.Environment: unexpected"
+
+valueToRegistry :: VarValue -> Registry.StringValue
+valueToRegistry value
+    | varValueExpandable value = (Registry.TypeExpandableString, varValueString value)
+    | otherwise = (Registry.TypeString, varValueString value)
 
 query :: Profile -> VarName -> ExceptT IOError IO VarValue
-query profile name = Registry.getStringDoNotExpand (profileKeyPath profile) name
+query profile name = valueFromRegistry <$> Registry.getStringValue (profileKeyPath profile) name
 
 engrave :: Profile -> VarName -> VarValue -> ExceptT IOError IO ()
 engrave profile name value = do
-    ret <- Registry.setStringPreserveType (profileKeyPath profile) name value
-    lift notifyEnvironmentUpdate
-    return ret
-
-engraveForce :: Profile -> VarName -> VarValue -> ExceptT IOError IO ()
-engraveForce profile name value = do
-    ret <- Registry.setString (profileKeyPath profile) name value
+    ret <- Registry.setStringValue (profileKeyPath profile) name $ valueToRegistry value
     lift notifyEnvironmentUpdate
     return ret
 
@@ -80,13 +91,13 @@ wipe profile name = do
     lift notifyEnvironmentUpdate
     return ret
 
-pathSep :: VarValue
+pathSep :: String
 pathSep = ";"
 
-pathSplit :: VarValue -> [VarValue]
+pathSplit :: String -> [String]
 pathSplit = filter (not . null) . splitOn pathSep
 
-pathJoin :: [VarValue] -> VarValue
+pathJoin :: [String] -> String
 pathJoin = intercalate pathSep . filter (not . null)
 
 #include "ccall.h"
@@ -96,7 +107,7 @@ pathJoin = intercalate pathSep . filter (not . null)
 foreign import WINDOWS_ENV_CCALL unsafe "Windows.h ExpandEnvironmentStringsW"
     c_ExpandEnvironmentStrings :: WinAPI.LPCTSTR -> WinAPI.LPTSTR -> WinAPI.DWORD -> IO WinAPI.ErrCode
 
-expand :: VarValue -> ExceptT IOError IO VarValue
+expand :: String -> ExceptT IOError IO String
 expand value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left)
   where
     doExpandIn valuePtr bufferPtr bufferLength = do
@@ -109,18 +120,18 @@ expand value = ExceptT $ catchIOError (Right <$> doExpand) (return . Left)
     doExpand = WinAPI.withTString value $ \valuePtr -> doExpandIn valuePtr WinAPI.nullPtr 0
 
 data ExpandedPath = ExpandedPath
-    { pathOriginal :: VarValue
-    , pathExpanded :: VarValue
+    { pathOriginal :: String
+    , pathExpanded :: String
     } deriving (Eq, Show)
 
-pathSplitAndExpand :: VarValue -> ExceptT IOError IO [ExpandedPath]
-pathSplitAndExpand pathValue = do
+pathSplitAndExpand :: String -> ExceptT IOError IO [ExpandedPath]
+pathSplitAndExpand value = do
     expandedOnce <- expandOnce
     zipWith ExpandedPath originalPaths <$>
         if length expandedOnce == length originalPaths
             then return expandedOnce
             else expandEach
   where
-    originalPaths = pathSplit pathValue
-    expandOnce = pathSplit <$> expand pathValue
+    originalPaths = pathSplit value
+    expandOnce = pathSplit <$> expand value
     expandEach = mapM expand originalPaths
diff --git a/src/WindowsEnv/Registry.hs b/src/WindowsEnv/Registry.hs
index 48200b2..73606d9 100644
--- a/src/WindowsEnv/Registry.hs
+++ b/src/WindowsEnv/Registry.hs
@@ -16,8 +16,9 @@ module WindowsEnv.Registry
     , KeyPath(..)
 
     , ValueName
-    , ValueType
-    , ValueData
+    , ValueType(..)
+    , Value
+    , StringValue
 
     , openKey
     , closeKey
@@ -30,16 +31,14 @@ module WindowsEnv.Registry
     , getValue
     , GetValueFlag(..)
     , getValueType
-    , getStringDoNotExpand
+    , getStringValue
 
     , setValue
-    , setString
-    , setExpandableString
-    , setStringPreserveType
+    , setStringValue
     ) where
 
 import           Control.Exception     (bracket)
-import           Control.Monad.Trans.Except (ExceptT(..), catchE, throwE)
+import           Control.Monad.Trans.Except (ExceptT(..))
 import           Data.Bits             ((.|.))
 import qualified Data.ByteString       as B
 import           Data.List             (intercalate)
@@ -51,7 +50,7 @@ import           Foreign.ForeignPtr    (withForeignPtr)
 import           Foreign.Marshal.Alloc (alloca, allocaBytes)
 import           Foreign.Marshal.Array (peekArray, pokeArray)
 import           Foreign.Storable      (peek, poke)
-import           System.IO.Error       (catchIOError, isDoesNotExistError)
+import           System.IO.Error       (catchIOError)
 import qualified System.Win32.Types    as WinAPI
 import qualified System.Win32.Registry as WinAPI
 
@@ -89,16 +88,16 @@ instance Show RootKey where
 
 data KeyPath = KeyPath RootKey [String]
 
-pathSep :: String
-pathSep = "\\"
+keyPathSep :: String
+keyPathSep = "\\"
 
 instance IsKeyPath KeyPath where
     openKeyUnsafe (KeyPath root path) = do
         rootHandle <- openKeyUnsafe root
-        WinAPI.regOpenKey rootHandle $ intercalate pathSep path
+        WinAPI.regOpenKey rootHandle $ intercalate keyPathSep path
 
 instance Show KeyPath where
-    show (KeyPath root path) = intercalate pathSep $ show root : path
+    show (KeyPath root path) = intercalate keyPathSep $ show root : path
 
 type ValueName = String
 
@@ -130,24 +129,25 @@ valueTypeNumbers =
     , (TypeLink,     6)
     ]
 
-type ValueData = (ValueType, B.ByteString)
+type Value = (ValueType, B.ByteString)
+type StringValue = (ValueType, String)
 
-encodeString :: String -> B.ByteString
-encodeString str = encodeUtf16LE addLastZero
+encodeString :: StringValue -> Value
+encodeString (valueType, valueData) = (valueType, encodeUtf16LE addLastZero)
   where
     addLastZero
         | T.null text = text
         | T.last text == '\0' = text
         | otherwise = T.snoc text '\0'
-    text = T.pack str
+    text = T.pack valueData
 
-decodeString :: ValueData -> String
-decodeString (_, bytes) = T.unpack dropLastZero
+decodeString :: Value -> StringValue
+decodeString (valueType, valueData) = (valueType, T.unpack dropLastZero)
   where
     dropLastZero
         | T.null text = text
         | otherwise = T.takeWhile (/= '\0') text
-    text = decodeUtf16LE bytes
+    text = decodeUtf16LE valueData
 
 #include "ccall.h"
 
@@ -162,7 +162,7 @@ foreign import WINDOWS_ENV_CCALL unsafe "Windows.h RegSetValueExW"
 foreign import WINDOWS_ENV_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 -> ExceptT IOError IO ValueData
+queryValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO Value
 queryValue keyPath valueName =
     withHandle keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -221,7 +221,7 @@ getValueFlagNumbers =
 collapseGetValueFlags :: Num a => [GetValueFlag] -> a
 collapseGetValueFlags = fromIntegral . foldr ((.|.) . fromEnum) 0
 
-getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO ValueData
+getValue :: IsKeyPath a => a -> ValueName -> [GetValueFlag] -> ExceptT IOError IO Value
 getValue keyPath valueName flags =
     withHandle keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -254,12 +254,11 @@ getValueType keyPath valueName flags =
   where
     collapsedFlags = collapseGetValueFlags $ DoNotExpand : flags
 
-getStringDoNotExpand :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO String
-getStringDoNotExpand keyPath valueName = do
-    valueData <- getValue keyPath valueName [RestrictExpandableString, RestrictString]
-    return $ decodeString valueData
+getStringValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO StringValue
+getStringValue keyPath valueName =
+    decodeString <$> getValue keyPath valueName [RestrictExpandableString, RestrictString]
 
-setValue :: IsKeyPath a => a -> ValueName -> ValueData -> ExceptT IOError IO ()
+setValue :: IsKeyPath a => a -> ValueName -> Value -> ExceptT IOError IO ()
 setValue keyPath valueName (valueType, valueData) =
     withHandle keyPath $ \keyHandle ->
     withForeignPtr keyHandle $ \keyHandlePtr ->
@@ -273,23 +272,9 @@ setValue keyPath valueName (valueType, valueData) =
     buffer = B.unpack valueData
     bufferSize = B.length valueData
 
-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 -> ExceptT IOError IO ()
-setExpandableString keyPath valueName valueData =
-    setValue keyPath valueName (TypeExpandableString, encodeString valueData)
-
-setStringPreserveType :: IsKeyPath a => a -> ValueName -> String -> ExceptT IOError IO ()
-setStringPreserveType keyPath valueName valueData = do
-    valueType <- getValueType keyPath valueName flags `catchE` stringByDefault
-    setValue keyPath valueName (valueType, encodeString valueData)
-  where
-    flags = [RestrictString, RestrictExpandableString]
-    stringByDefault e
-        | isDoesNotExistError e = return TypeString
-        | otherwise = throwE e
+setStringValue :: IsKeyPath a => a -> ValueName -> StringValue -> ExceptT IOError IO ()
+setStringValue keyPath valueName value =
+    setValue keyPath valueName $ encodeString value
 
 deleteValue :: IsKeyPath a => a -> ValueName -> ExceptT IOError IO ()
 deleteValue keyPath valueName =