optparse-applicative instead of GetOpt

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