diff options
Diffstat (limited to '')
-rw-r--r-- | apps/AddPath.hs | 85 | ||||
-rw-r--r-- | apps/FixNtSymbolPath.hs | 50 | ||||
-rw-r--r-- | apps/ListPath.hs | 66 | ||||
-rw-r--r-- | apps/RemovePath.hs | 92 | ||||
-rw-r--r-- | apps/SetEnv.hs | 65 | ||||
-rw-r--r-- | apps/UnsetEnv.hs | 63 |
6 files changed, 215 insertions, 206 deletions
diff --git a/apps/AddPath.hs b/apps/AddPath.hs index 558c23c..e3f8ec3 100644 --- a/apps/AddPath.hs +++ b/apps/AddPath.hs @@ -4,73 +4,76 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where -import Control.Monad ( mapM_, when ) +import Control.Monad (mapM_, when) import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - addPath args options - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + addPath args options + (_, _, errorMessages) -> exitWithUsageErrors errorMessages addPath :: [String] -> Options -> IO () addPath paths options = do - missingPaths <- dropIncludedPaths paths - when (not $ null missingPaths) $ do - oldPath <- Environment.queryFromRegistry (env options) (name options) - Environment.saveToRegistryWithPrompt (env options) (name options) $ Environment.joinPaths $ missingPaths ++ [oldPath] - where - dropIncludedPaths paths = do - currentPath <- Environment.getEnv $ name options - return $ filter (flip notElem $ Environment.splitPaths currentPath) paths + missingPaths <- dropIncludedPaths paths + when (not $ null missingPaths) $ do + oldPath <- Environment.queryFromRegistry (env options) (name options) + Environment.saveToRegistryWithPrompt (env options) (name options) $ Environment.joinPaths $ missingPaths ++ [oldPath] + where + dropIncludedPaths paths = do + currentPath <- Environment.getEnv $ name options + return $ filter (flip notElem $ Environment.splitPaths currentPath) paths -data Options = Options { name :: String - , env :: Environment.RegistryBasedEnvironment } - deriving (Eq, Show) +data Options = Options + { name :: String + , env :: Environment.RegistryBasedEnvironment + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { name = "PATH" - , env = Environment.CurrentUserEnvironment } +defaultOptions = Options + { name = "PATH" + , env = Environment.CurrentUserEnvironment + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader :: IO String + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] [PATH...]\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)", - Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "add the path for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)" + , Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "add the path for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/FixNtSymbolPath.hs b/apps/FixNtSymbolPath.hs index 9a02cf9..c75291e 100644 --- a/apps/FixNtSymbolPath.hs +++ b/apps/FixNtSymbolPath.hs @@ -4,46 +4,44 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where -import Control.Monad ( unless ) -import System.Directory ( createDirectoryIfMissing, getCurrentDirectory ) -import System.FilePath ( combine ) +import Control.Monad (unless) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath (combine) import qualified Environment getRemoteSymbolsDirectoryPath :: IO String getRemoteSymbolsDirectoryPath = do - localPath <- getLocalPath - createDirectoryIfMissing True localPath - return $ "SRV*" ++ localPath ++ "*" ++ remotePath - where - getLocalPath :: IO String - getLocalPath = do + localPath <- getLocalPath + createDirectoryIfMissing True localPath + return $ "SRV*" ++ localPath ++ "*" ++ remotePath + where + getLocalPath = do cwd <- getCurrentDirectory return $ combine cwd "symbols" - remotePath :: String - remotePath = "http://msdl.microsoft.com/download/symbols" + remotePath = "http://msdl.microsoft.com/download/symbols" getPdbsDirectoryPath :: IO String getPdbsDirectoryPath = do - cwd <- getCurrentDirectory - let path = combine cwd "pdbs" - createDirectoryIfMissing True path - return path + cwd <- getCurrentDirectory + let path = combine cwd "pdbs" + createDirectoryIfMissing True path + return path fixNtSymbolPath :: IO () fixNtSymbolPath = do - let env = Environment.CurrentUserEnvironment - val <- Environment.queryFromRegistry env ntSymbolPath - let presentPaths = Environment.splitPaths val - remoteSymbolsPath <- getRemoteSymbolsDirectoryPath - pdbsPath <- getPdbsDirectoryPath - let requiredPaths = [pdbsPath, remoteSymbolsPath] - let missingPaths = filter (`notElem` presentPaths) requiredPaths - unless (null missingPaths) $ do - let newval = Environment.joinPaths $ presentPaths ++ missingPaths - Environment.saveToRegistry env ntSymbolPath newval + let env = Environment.CurrentUserEnvironment + val <- Environment.queryFromRegistry env ntSymbolPath + let presentPaths = Environment.splitPaths val + remoteSymbolsPath <- getRemoteSymbolsDirectoryPath + pdbsPath <- getPdbsDirectoryPath + let requiredPaths = [pdbsPath, remoteSymbolsPath] + let missingPaths = filter (`notElem` presentPaths) requiredPaths + unless (null missingPaths) $ do + let newval = Environment.joinPaths $ presentPaths ++ missingPaths + Environment.saveToRegistry env ntSymbolPath newval where ntSymbolPath = "_NT_SYMBOL_PATH" diff --git a/apps/ListPath.hs b/apps/ListPath.hs index 75f1b27..b964998 100644 --- a/apps/ListPath.hs +++ b/apps/ListPath.hs @@ -4,33 +4,33 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where import System.Console.GetOpt -import System.Directory ( doesDirectoryExist ) -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Directory (doesDirectoryExist) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - case args of - [] -> listPath options - _ -> invalidNumberOfArguments - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + case args of + [] -> listPath options + _ -> invalidNumberOfArguments + (_, _, errorMessages) -> exitWithUsageErrors errorMessages listPath :: Options -> IO () listPath options = do - val <- Environment.getEnv $ name options - mapM_ printPath $ Environment.splitPaths val - where - printPath p = do + val <- Environment.getEnv $ name options + mapM_ printPath $ Environment.splitPaths val + where + printPath p = do exists <- doesDirectoryExist p putStrLn $ (if exists then "+" else "-") ++ " " ++ p @@ -41,32 +41,32 @@ defaultOptions = Options { name = "PATH" } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader :: IO String + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...]\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs index 3071708..2f73e21 100644 --- a/apps/RemovePath.hs +++ b/apps/RemovePath.hs @@ -4,77 +4,79 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where -import Control.Monad ( when ) +import Control.Monad (when) import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - removePath args options - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + removePath args options + (_, _, errorMessages) -> exitWithUsageErrors errorMessages removePath :: [String] -> Options -> IO () removePath paths options = do - let varName = name options - userVal <- Environment.queryFromRegistry Environment.CurrentUserEnvironment varName - let userValParts = Environment.splitPaths userVal - let newUserValParts = filter (`notElem` paths) userValParts - when (length userValParts /= length newUserValParts) $ do - Environment.saveToRegistryWithPrompt Environment.CurrentUserEnvironment varName $ Environment.joinPaths newUserValParts - when (global options) $ do - globalVal <- Environment.queryFromRegistry Environment.AllUsersEnvironment varName - let globalValParts = Environment.splitPaths globalVal - let newGlobalValParts = filter (`notElem` paths) globalValParts - when (length globalValParts /= length newGlobalValParts) $ do - Environment.saveToRegistryWithPrompt Environment.AllUsersEnvironment varName $ Environment.joinPaths newGlobalValParts + let varName = name options + userVal <- Environment.queryFromRegistry Environment.CurrentUserEnvironment varName + let userValParts = Environment.splitPaths userVal + let newUserValParts = filter (`notElem` paths) userValParts + when (length userValParts /= length newUserValParts) $ do + Environment.saveToRegistryWithPrompt Environment.CurrentUserEnvironment varName $ Environment.joinPaths newUserValParts + when (global options) $ do + globalVal <- Environment.queryFromRegistry Environment.AllUsersEnvironment varName + let globalValParts = Environment.splitPaths globalVal + let newGlobalValParts = filter (`notElem` paths) globalValParts + when (length globalValParts /= length newGlobalValParts) $ do + Environment.saveToRegistryWithPrompt Environment.AllUsersEnvironment varName $ Environment.joinPaths newGlobalValParts -data Options = Options { name :: String - , global :: Bool } - deriving (Eq, Show) +data Options = Options + { name :: String + , global :: Bool + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { name = "PATH" - , global = False } +defaultOptions = Options + { name = "PATH" + , global = False + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] [PATH...]\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)", - Option "g" ["global"] (NoArg $ \opts -> return opts { global = True }) "remove the path for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "n" ["name"] (ReqArg (\s opts -> return opts { name = s }) "NAME") "set the variable name ('PATH' by default)" + , Option "g" ["global"] (NoArg $ \opts -> return opts { global = True }) "remove the path for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs index fda9726..f27be4e 100644 --- a/apps/SetEnv.hs +++ b/apps/SetEnv.hs @@ -4,63 +4,66 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - case args of - [name, value] -> setEnv name value options - _ -> invalidNumberOfArguments - (_, _, errorMessages) -> - exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + case args of + [name, value] -> setEnv name value options + _ -> invalidNumberOfArguments + (_, _, errorMessages) -> + exitWithUsageErrors errorMessages setEnv :: String -> String -> Options -> IO () setEnv name value options = Environment.saveToRegistryWithPrompt (env options) name value -data Options = Options { env :: Environment.RegistryBasedEnvironment } deriving (Eq, Show) +data Options = Options + { env :: Environment.RegistryBasedEnvironment + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { env = Environment.CurrentUserEnvironment } +defaultOptions = Options + { env = Environment.CurrentUserEnvironment + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME VALUE\nOptions:" exitWithHelpMessage :: Options -> IO a exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "save under the registry key for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "save under the registry key for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs index 254f383..32626f3 100644 --- a/apps/UnsetEnv.hs +++ b/apps/UnsetEnv.hs @@ -4,62 +4,65 @@ - See LICENSE.txt for details. -} -module Main ( main ) where +module Main (main) where import System.Console.GetOpt -import System.Environment ( getArgs, getProgName ) -import System.Exit ( exitFailure, exitSuccess ) -import System.IO ( hPutStr, stderr ) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) import qualified Environment main :: IO () main = do - rawArgs <- getArgs - case getOpt Permute optionDescription rawArgs of - (actions, args, []) -> do - options <- foldl (>>=) (return defaultOptions) actions - case args of - [name] -> unsetEnv name options - _ -> invalidNumberOfArguments - (_, _, errorMessages) -> exitWithUsageErrors errorMessages + rawArgs <- getArgs + case getOpt Permute optionDescription rawArgs of + (actions, args, []) -> do + options <- foldl (>>=) (return defaultOptions) actions + case args of + [name] -> unsetEnv name options + _ -> invalidNumberOfArguments + (_, _, errorMessages) -> exitWithUsageErrors errorMessages unsetEnv :: String -> Options -> IO () unsetEnv name options = Environment.wipeFromRegistryWithPrompt (env options) name -data Options = Options { env :: Environment.RegistryBasedEnvironment } deriving (Eq, Show) +data Options = Options + { env :: Environment.RegistryBasedEnvironment + } deriving (Eq, Show) defaultOptions :: Options -defaultOptions = Options { env = Environment.CurrentUserEnvironment } +defaultOptions = Options + { env = Environment.CurrentUserEnvironment + } buildHelpMessage :: IO String buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription - where - buildHeader :: IO String - buildHeader = do + header <- buildHeader + return $ usageInfo header optionDescription + where + buildHeader = do progName <- getProgName return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME\nOptions:" exitWithHelpMessage :: a -> IO b exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + helpMessage <- buildHelpMessage + putStr helpMessage + exitSuccess exitWithUsageErrors :: [String] -> IO a exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure + hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages + helpMessage <- buildHelpMessage + hPutStr stderr helpMessage + exitFailure invalidNumberOfArguments :: IO a invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] optionDescription :: [OptDescr (Options -> IO Options)] -optionDescription = [ - Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "delete from the registry key for all users", - Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" - ] +optionDescription = + [ Option "g" ["global"] (NoArg $ \opts -> return opts { env = Environment.AllUsersEnvironment }) "delete from the registry key for all users" + , Option "h" ["help"] (NoArg exitWithHelpMessage) "show this message and exit" + ] |