diff options
| -rw-r--r-- | apps/AddPath.hs | 97 | ||||
| -rw-r--r-- | apps/ListPath.hs | 67 | ||||
| -rw-r--r-- | apps/RemovePath.hs | 89 | ||||
| -rw-r--r-- | apps/SetEnv.hs | 80 | ||||
| -rw-r--r-- | apps/UnsetEnv.hs | 74 | ||||
| -rw-r--r-- | src/Utils.hs | 4 | ||||
| -rw-r--r-- | wintmp.cabal | 5 |
7 files changed, 142 insertions, 274 deletions
diff --git a/apps/AddPath.hs b/apps/AddPath.hs index e3f8ec3..85f2aa4 100644 --- a/apps/AddPath.hs +++ b/apps/AddPath.hs @@ -6,74 +6,49 @@ module Main (main) where -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 Control.Monad (when) -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 +import Options.Applicative -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 +import qualified Environment data Options = Options { name :: String - , env :: Environment.RegistryBasedEnvironment + , global :: Bool + , paths :: [String] } deriving (Eq, Show) -defaultOptions :: Options -defaultOptions = Options - { name = "PATH" - , env = Environment.CurrentUserEnvironment - } - -buildHelpMessage :: IO String -buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription +options :: Parser Options +options = Options + <$> nameOption + <*> globalOption + <*> pathArgs where - buildHeader :: IO String - buildHeader = do - progName <- getProgName - return $ "Usage: " ++ progName ++ " [OPTIONS...] [PATH...]\nOptions:" + nameOption = strOption $ + long "name" <> short 'n' <> metavar "NAME" <> value "PATH" <> + help "Specify variable name ('PATH' by default)" + globalOption = switch $ + long "global" <> short 'g' <> + help "Whether to add for all users" + pathArgs = many $ argument str $ + metavar "PATH" <> + help "Directory path(s)" -exitWithHelpMessage :: a -> IO b -exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure - -invalidNumberOfArguments :: IO a -invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] +main :: IO () +main = execParser parser >>= addPath + where + parser = info (helper <*> options) $ + fullDesc <> progDesc "Add directories to your PATH" -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" - ] +addPath :: Options -> IO () +addPath options = do + missingPaths <- dropIncludedPaths $ paths options + when (not $ null missingPaths) $ do + oldPath <- Environment.queryFromRegistry env $ name options + Environment.saveToRegistryWithPrompt env (name options) $ Environment.joinPaths $ missingPaths ++ [oldPath] + where + dropIncludedPaths paths = do + currentPath <- Environment.getEnv $ name options + return $ filter (flip notElem $ Environment.splitPaths currentPath) paths + env | global options = Environment.AllUsersEnvironment + | otherwise = Environment.CurrentUserEnvironment diff --git a/apps/ListPath.hs b/apps/ListPath.hs index b964998..95d9c8b 100644 --- a/apps/ListPath.hs +++ b/apps/ListPath.hs @@ -6,24 +6,28 @@ 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 Options.Applicative import qualified Environment +data Options = Options + { name :: String + } deriving (Eq, Show) + +options :: Parser Options +options = Options <$> nameOption + where + nameOption = strOption $ + long "name" <> short 'n' <> metavar "NAME" <> value "PATH" <> + help "Specify variable name ('PATH' by default)" + 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 +main = execParser parser >>= listPath + where + parser = info (helper <*> options) $ + fullDesc <> progDesc "List directories in your PATH" listPath :: Options -> IO () listPath options = do @@ -33,40 +37,3 @@ listPath options = do printPath p = do exists <- doesDirectoryExist p putStrLn $ (if exists then "+" else "-") ++ " " ++ p - -data Options = Options { name :: String } deriving (Eq, Show) - -defaultOptions :: Options -defaultOptions = Options { name = "PATH" } - -buildHelpMessage :: IO String -buildHelpMessage = 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 - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - 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" - ] diff --git a/apps/RemovePath.hs b/apps/RemovePath.hs index 2f73e21..d85a7f4 100644 --- a/apps/RemovePath.hs +++ b/apps/RemovePath.hs @@ -7,76 +7,49 @@ module Main (main) where import Control.Monad (when) -import System.Console.GetOpt -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure, exitSuccess) -import System.IO (hPutStr, stderr) + +import Options.Applicative import qualified Environment +data Options = Options + { name :: String + , global :: Bool + , paths :: [String] + } deriving (Eq, Show) + +options = Options + <$> nameOption + <*> globalOption + <*> pathArgs + where + nameOption = strOption $ + long "name" <> short 'n' <> metavar "NAME" <> value "PATH" <> + help "Specify variable name ('PATH' by default)" + globalOption = switch $ + long "global" <> short 'g' <> + help "Whether to remove for all users" + pathArgs = many $ argument str $ + metavar "PATH" <> + help "Directory path(s)" + 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 +main = execParser parser >>= removePath + where + parser = info (helper <*> options) $ + fullDesc <> progDesc "Remove directories from your PATH" -removePath :: [String] -> Options -> IO () -removePath paths options = do +removePath :: Options -> IO () +removePath options = do let varName = name options userVal <- Environment.queryFromRegistry Environment.CurrentUserEnvironment varName let userValParts = Environment.splitPaths userVal - let newUserValParts = filter (`notElem` paths) userValParts + let newUserValParts = filter (flip notElem $ paths options) 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 + let newGlobalValParts = filter (flip notElem $ paths options) 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) - -defaultOptions :: Options -defaultOptions = Options - { name = "PATH" - , global = False - } - -buildHelpMessage :: IO String -buildHelpMessage = 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 - -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - 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" - ] diff --git a/apps/SetEnv.hs b/apps/SetEnv.hs index f27be4e..d3439ae 100644 --- a/apps/SetEnv.hs +++ b/apps/SetEnv.hs @@ -6,64 +6,40 @@ module Main (main) where -import System.Console.GetOpt -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure, exitSuccess) -import System.IO (hPutStr, stderr) +import Options.Applicative hiding (value) 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 - -setEnv :: String -> String -> Options -> IO () -setEnv name value options = Environment.saveToRegistryWithPrompt (env options) name value - data Options = Options - { env :: Environment.RegistryBasedEnvironment + { global :: Bool + , name :: String + , value :: String } deriving (Eq, Show) -defaultOptions :: Options -defaultOptions = Options - { env = Environment.CurrentUserEnvironment - } - -buildHelpMessage :: IO String -buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription +options :: Parser Options +options = Options + <$> globalOption + <*> nameArg + <*> valueArg where - buildHeader = do - progName <- getProgName - return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME VALUE\nOptions:" - -exitWithHelpMessage :: Options -> IO a -exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + globalOption = switch $ + long "global" <> short 'g' <> + help "Whether to set for all users" + nameArg = argument str $ + metavar "NAME" <> + help "Variable name" + valueArg = argument str $ + metavar "VALUE" <> + help "Variable value" -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure - -invalidNumberOfArguments :: IO a -invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] +main :: IO () +main = execParser parser >>= setEnv + where + parser = info (helper <*> options) $ + fullDesc <> progDesc "Set environment variables" -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" - ] +setEnv :: Options -> IO () +setEnv options = Environment.saveToRegistryWithPrompt env (name options) (value options) + where + env | global options = Environment.AllUsersEnvironment + | otherwise = Environment.CurrentUserEnvironment diff --git a/apps/UnsetEnv.hs b/apps/UnsetEnv.hs index 32626f3..bf7ad93 100644 --- a/apps/UnsetEnv.hs +++ b/apps/UnsetEnv.hs @@ -6,63 +6,35 @@ module Main (main) where -import System.Console.GetOpt -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure, exitSuccess) -import System.IO (hPutStr, stderr) +import Options.Applicative 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 - -unsetEnv :: String -> Options -> IO () -unsetEnv name options = Environment.wipeFromRegistryWithPrompt (env options) name - data Options = Options - { env :: Environment.RegistryBasedEnvironment + { global :: Bool + , name :: String } deriving (Eq, Show) -defaultOptions :: Options -defaultOptions = Options - { env = Environment.CurrentUserEnvironment - } - -buildHelpMessage :: IO String -buildHelpMessage = do - header <- buildHeader - return $ usageInfo header optionDescription +options :: Parser Options +options = Options + <$> globalOption + <*> nameArg where - buildHeader = do - progName <- getProgName - return $ "Usage: " ++ progName ++ " [OPTIONS...] NAME\nOptions:" - -exitWithHelpMessage :: a -> IO b -exitWithHelpMessage _ = do - helpMessage <- buildHelpMessage - putStr helpMessage - exitSuccess + globalOption = switch $ + long "global" <> short 'g' <> + help "Whether to unset for all users" + nameArg = argument str $ + metavar "NAME" <> + help "Variable name" -exitWithUsageErrors :: [String] -> IO a -exitWithUsageErrors errorMessages = do - hPutStr stderr $ concatMap ("Usage error: " ++) errorMessages - helpMessage <- buildHelpMessage - hPutStr stderr helpMessage - exitFailure - -invalidNumberOfArguments :: IO a -invalidNumberOfArguments = exitWithUsageErrors ["invalid number of arguments\n"] +main :: IO () +main = execParser parser >>= unsetEnv + where + parser = info (helper <*> options) $ + fullDesc <> progDesc "Unset environment variables" -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" - ] +unsetEnv :: Options -> IO () +unsetEnv options = Environment.wipeFromRegistryWithPrompt env $ name options + where + env | global options = Environment.AllUsersEnvironment + | otherwise = Environment.CurrentUserEnvironment diff --git a/src/Utils.hs b/src/Utils.hs index ec15405..143696b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -7,8 +7,8 @@ module Utils where import Control.Monad (liftM) -import Data.Char (toLower) -import System.IO (hFlush, stdout) +import Data.Char (toLower) +import System.IO (hFlush, stdout) prompt :: String -> IO String prompt banner = do diff --git a/wintmp.cabal b/wintmp.cabal index 8e73e63..a8a8437 100644 --- a/wintmp.cabal +++ b/wintmp.cabal @@ -25,6 +25,7 @@ executable add_path main-is: AddPath.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base + , optparse-applicative , wintmp default-language: Haskell2010 @@ -41,6 +42,7 @@ executable list_path main-is: ListPath.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base, directory + , optparse-applicative , wintmp default-language: Haskell2010 @@ -49,6 +51,7 @@ executable remove_path main-is: RemovePath.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base + , optparse-applicative , wintmp default-language: Haskell2010 @@ -57,6 +60,7 @@ executable set_env main-is: SetEnv.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base + , optparse-applicative , wintmp default-language: Haskell2010 @@ -65,6 +69,7 @@ executable unset_env main-is: UnsetEnv.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base + , optparse-applicative , wintmp default-language: Haskell2010 |