Optparse-applicative CLI

exe/Main.hs

@@ -1,18 +1,14 @@
-{-# LANGUAGE DeriveDataTypeable, LambdaCase #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Main where
 
 import Config (cProjectVersion)
 
-import Control.Exception (Exception, Handler(..), ErrorCall(..))
-import qualified Control.Exception as E
 import Control.Monad ( forM )
-import Data.Typeable (Typeable)
 import Data.Version (showVersion)
+import Options.Applicative
 import System.Directory (getCurrentDirectory)
-import System.Environment (getArgs)
-import System.Exit (exitFailure)
-import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)
+import System.IO (stdout, hSetEncoding, utf8)
 import System.FilePath( (</>) )
 
 import HIE.Bios
@@ -25,99 +21,77 @@ import Paths_hie_bios
 progVersion :: String
 progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
 
-ghcOptHelp :: String
-ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "
-
-usage :: String
-usage =    progVersion
-        ++ "Usage:\n"
-        ++ "\t hie-bios check" ++ ghcOptHelp ++ "<HaskellFiles...>\n"
-        ++ "\t hie-bios expand <HaskellFiles...>\n"
-        ++ "\t hie-bios flags <HaskellFiles...>\n"
-        ++ "\t hie-bios debug [<ComponentDir>]\n"
-        ++ "\t hie-bios config <HaskellFiles...>\n"
-        ++ "\t hie-bios cradle <HaskellFiles...>\n"
-        ++ "\t hie-bios root\n"
-        ++ "\t hie-bios version\n"
+data Command
+  = Check { checkTargetFiles :: [FilePath] }
+  | Flags { flagTargetFiles :: [FilePath] }
+  | Debug { debugComponents :: FilePath }
+  | ConfigInfo { configFiles :: [FilePath] }
+  | CradleInfo { cradleFiles :: [FilePath] }
+  | Root
+  | Version
 
-----------------------------------------------------------------
 
-data HhpcError = SafeList
-               | TooManyArguments String
-               | NotEnoughArguments String
-               | NoSuchCommand String
-               | CmdArg [String]
-               | FileNotExist String deriving (Show, Typeable)
+filepathParser :: Parser [FilePath]
+filepathParser = some (argument str ( metavar "TARGET_FILES..."))
+
+progInfo :: ParserInfo Command
+progInfo = info (progParser <**> helper)
+  ( fullDesc
+  <> progDesc "hie-bios is the way to specify how haskell-language-server and ghcide set up a GHC API session.\
+              \Delivers the full set of flags to pass to GHC in order to build the project."
+  <> header progVersion
+  <> footer "You can report issues/contribute at https://github.com/mpickering/hie-bios")
+
+progParser :: Parser Command
+progParser = subparser
+    (command "check" (info (Check <$> filepathParser) (progDesc "Try to load modules into the GHC API."))
+    <> command "flags" (info (Flags <$> filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file."))
+    <> command "debug" (info (Debug <$> argument str ( metavar "TARGET_FILES...")) (progDesc "Print out the options that hie-bios thinks you will need to load a file."))
+    <> command "config" (info (ConfigInfo <$> filepathParser) (progDesc "Print out the cradle config."))
+    <> command "cradle" (info (CradleInfo <$> filepathParser) (progDesc "."))
+    <> command "root" (info (pure Root) (progDesc "Display the path towards the selected hie.yaml."))
+    <> command "version" (info (pure Version) (progDesc "Print version and exit."))
+    )
 
-instance Exception HhpcError
 
 ----------------------------------------------------------------
 
 main :: IO ()
-main = flip E.catches handlers $ do
+main = do
     hSetEncoding stdout utf8
-    args <- getArgs
     cwd <- getCurrentDirectory
     cradle <-
         -- find cradle does a takeDirectory on the argument, so make it into a file
         findCradle (cwd </> "File.hs") >>= \case
           Just yaml -> loadCradle yaml
           Nothing -> loadImplicitCradle (cwd </> "File.hs")
-    let cmdArg0 = args !. 0
-        remainingArgs = tail args
-    res <- case cmdArg0 of
-      "check"   -> checkSyntax cradle remainingArgs
-      "debug"
-        | null remainingArgs -> debugInfo (cradleRootDir cradle) cradle
-        | (fp:_) <- remainingArgs -> debugInfo fp cradle
-      "root"    -> rootInfo cradle
-      "version" -> return progVersion
-      "config" -> configInfo remainingArgs
-      "cradle" -> cradleInfo remainingArgs
-      "flags"
-        | null remainingArgs -> E.throw $ NotEnoughArguments cmdArg0
-        | otherwise -> do
-        res <- forM remainingArgs $ \fp -> do
-                res <- getCompilerOptions fp cradle
-                case res of
-                    CradleFail (CradleError _deps _ex err) ->
-                      return $ "Failed to show flags for \""
-                                                ++ fp
-                                                ++ "\": " ++ show err
-                    CradleSuccess opts ->
-                      return $ unlines ["Options: " ++ show (componentOptions opts)
-                                       ,"ComponentDir: " ++ (componentRoot opts)
-                                       ,"Dependencies: " ++ show (componentDependencies opts) ]
-                    CradleNone -> return "No flags: this component should not be loaded"
-        return (unlines res)
-
-      "help"    -> return usage
-      "--help"  -> return usage
-      "-h"      -> return usage
-
-      cmd       -> E.throw (NoSuchCommand cmd)
+
+    cmd <- execParser progInfo
+
+    res <- case cmd of
+      Check targetFiles -> checkSyntax cradle targetFiles
+      Debug files -> case files of
+        [] -> debugInfo (cradleRootDir cradle) cradle
+        fp -> debugInfo fp cradle
+      Flags files -> case files of
+        -- TODO force optparse to acquire one
+        [] -> error "too few arguments"
+        _ -> do
+          res <- forM files $ \fp -> do
+                  res <- getCompilerOptions fp cradle
+                  case res of
+                      CradleFail (CradleError _deps _ex err) ->
+                        return $ "Failed to show flags for \""
+                                                  ++ fp
+                                                  ++ "\": " ++ show err
+                      CradleSuccess opts ->
+                        return $ unlines ["Options: " ++ show (componentOptions opts)
+                                        ,"ComponentDir: " ++ componentRoot opts
+                                        ,"Dependencies: " ++ show (componentDependencies opts) ]
+                      CradleNone -> return $ "No flags/None Cradle: component " ++ fp ++ " should not be loaded"
+          return (unlines res)
+      ConfigInfo files -> configInfo files
+      CradleInfo files -> cradleInfo files
+      Root    -> rootInfo cradle
+      Version -> return progVersion
     putStr res
-  where
-    handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
-    handleThenExit handler e = handler e >> exitFailure
-    handler1 :: ErrorCall -> IO ()
-    handler1 = print -- for debug
-    handler2 :: HhpcError -> IO ()
-    handler2 SafeList = hPutStr stderr usage
-    handler2 (TooManyArguments cmd) =
-        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments"
-    handler2 (NotEnoughArguments cmd) = do
-        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Not enough arguments"
-        hPutStrLn stderr ""
-        hPutStr stderr usage
-    handler2 (NoSuchCommand cmd) = do
-        hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"
-        hPutStrLn stderr ""
-        hPutStr stderr usage
-    handler2 (CmdArg errs) =
-        mapM_ (hPutStr stderr) errs
-    handler2 (FileNotExist file) =
-        hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
-    xs !. idx
-      | length xs <= idx = E.throw SafeList
-      | otherwise = xs !! idx

hie-bios.cabal

@@ -182,6 +182,7 @@ Executable hie-bios
                       , filepath
                       , ghc
                       , hie-bios
+                      , optparse-applicative
 
 test-suite parser-tests
   type: exitcode-stdio-1.0

src/HIE/Bios/Ghc/Check.hs

@@ -41,7 +41,7 @@ checkSyntax cradle files = do
   where
     handleRes (CradleSuccess x) f = f x
     handleRes (CradleFail ce) _f = liftIO $ throwIO ce 
-    handleRes CradleNone _f = return "No cradle"
+    handleRes CradleNone _f = return "None cradle"
 
 ----------------------------------------------------------------