optparse-applicative instead of GetOpt

1 files changed, 17 insertions, 50 deletions

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"
-    ]