[haskell_edsl] Proper commandline parsing and -q option

Author: jbransen

haskell_edsl/checktestdata.cabal

@@ -28,6 +28,7 @@ library
                        containers >=0.5 && <0.6,
                        either >=4.3 && <4.5,
                        mtl >=2.2 && <2.3,
+                       optparse-applicative >= 0.13.1,
                        regex-tdfa >= 1.2,
                        uu-parsinglib >= 2.9
   hs-source-dirs:      src
@@ -38,6 +39,7 @@ executable checktestdata
   main-is:             Main.hs
   hs-source-dirs:      src-main
   build-depends:       base >=4.7 && <4.10,
+                       optparse-applicative >= 0.13.1,
                        checktestdata -any
   default-language:    Haskell2010
   ghc-options:         -Wall -O2

haskell_edsl/src-main/Main.hs

@@ -1,24 +1,31 @@
-module Main where
-
-import Checktestdata
-import Checktestdata.Script
-
-import System.Environment ( getArgs, withArgs, getProgName )
-import System.Exit        ( exitFailure)
-
-main :: IO ()
-main = do
-  args <- getArgs
-  case args of
-    []   -> printUsage
-    (fp:rargs) -> do
-      ast <- parseScript fp
-      withArgs rargs $ ctdMain $ interpret ast
-
-printUsage :: IO ()
-printUsage = do
-      nm <- getProgName
-      putStrLn $ "Usage:"
-      putStrLn $ "  " ++ nm ++ " script.ctd data.in"
-      putStrLn $ "  " ++ nm ++ " script.ctd < data.in"
-      exitFailure
+module Main where
+
+import Checktestdata
+import Checktestdata.Script
+import Checktestdata.Options
+
+import Options.Applicative
+import Data.Semigroup ((<>))
+
+
+main :: IO ()
+main = do
+  opts <- execParser $ info (mainOpts <**> helper)
+    ( fullDesc
+      <> progDesc "Check the data for testdata.in with script.ctd"
+      <> header "checktestdata" )
+  ast <- parseScript $ script_file opts
+  ctdMainOpts (script_options opts) $ interpret ast
+
+
+-- | Parser for the commandline options of a checktestdata script.
+mainOpts :: Parser MainOptions
+mainOpts = MainOptions
+  <$> argument str (metavar "script.ctd")
+  <*> generalOpts
+
+
+data MainOptions = MainOptions {
+  script_file    :: FilePath,
+  script_options :: Options
+  }

haskell_edsl/src-main/Test.hs

@@ -85,8 +85,11 @@ checkRun :: Options -> FilePath -> FilePath -> IO (Either String ())
 checkRun opts prog dataf = do
   res <- try $ do
     ctd <- parseScript $ testsdir ++ prog
-    runCTDFile opts (interpret ctd) $ testsdir ++ dataf
+    let sopts = opts {
+          input_file = Just $ testsdir ++ dataf,
+          quiet = True
+          }
+    ctdMainOpts sopts (interpret ctd)
   case res of
     Left e -> return $ Left $ show (e :: SomeException)
-    Right (Left e) -> return $ Left e
-    Right (Right _) -> return $ Right ()
+    Right () -> return $ Right ()

haskell_edsl/src/Checktestdata.hs

@@ -5,7 +5,10 @@ module Checktestdata (
 
   -- * Main functionality
   ctdMain,
-  runCTDFile,
+  ctdMainOpts,
+
+  -- * Commandline parsers
+  generalOpts,
 
   -- * Primitives
   peekChar,
@@ -31,38 +34,58 @@ import Checktestdata.Core
 import Checktestdata.Derived
 import Checktestdata.Options
 
-import System.Environment ( getArgs, getProgName )
-import System.Exit        ( exitFailure, exitSuccess)
+import System.Exit        ( exitFailure )
 import System.IO          ( hPutStrLn, stderr)
 
-import qualified Data.ByteString.Char8 as BS
+import Control.Monad      ( when )
+
+import Options.Applicative
+import Data.Semigroup ((<>))
 
--- | Run a checktestdata script on a file
-runCTDFile :: Options -> CTD a -> FilePath -> IO (Either String a)
-runCTDFile opts sc fp = do
-  f <- BS.readFile fp
-  return $ runCTD opts sc f
+import qualified Data.ByteString.Char8 as BS
 
 -- | Main function that reads the commandline arguments
 --   and takes either a filename or reads from stdin.
 ctdMain :: CTD a -> IO ()
 ctdMain sc = do
-  args <- getArgs
-  -- todo: add -w options to commandline arguments
-  bs <- case args of
-    []    -> BS.getContents
-    ["-"] -> BS.getContents
-    [fp]  -> BS.readFile fp
-    _     -> do
-      nm <- getProgName
-      putStrLn $ "Usage:"
-      putStrLn $ "  " ++ nm ++ " data.in"
-      putStrLn $ "  " ++ nm ++ " < data.in"
-      exitFailure
-  case runCTD defaultOptions sc bs of
+  opts <- execParser $ info (generalOpts <**> helper)
+    ( fullDesc
+      <> progDesc "Check the data for testdata.in"
+      <> header "checktestdata" )
+  ctdMainOpts opts sc
+
+-- | Main function that reads the input file given in the options.
+ctdMainOpts :: Options -> CTD a -> IO ()
+ctdMainOpts opts sc = do
+  bs <- case input_file opts of
+    Nothing  -> BS.getContents
+    Just "-" -> BS.getContents
+    Just fp  -> BS.readFile fp
+  case runCTD opts sc bs of
     Left err -> do
-      hPutStrLn stderr err
+      when (not $ quiet opts) $
+        hPutStrLn stderr err
       exitFailure
     Right _ -> do
-      putStrLn "Testdata OK"
-      exitSuccess
+      when (not $ quiet opts) $
+        putStrLn "Testdata OK"
+
+
+--------------------------------------------------------------------------------
+-- Command line option parsing
+--------------------------------------------------------------------------------
+
+-- | Parser for the general commandline options.
+generalOpts :: Parser Options
+generalOpts = Options
+  <$> switch
+  ( long "whitespace-ok"
+    <> short 'w'
+    <> help "whitespace changes are accepted, including heading and trailing whitespace, but not newlines; be careful: extra whitespace matches greedily!" )
+  <*> switch
+  ( long "quiet"
+    <> short 'q'
+    <> help "don't display testdata error messages: test exitcode" )
+  <*> optional (argument str (metavar "testdata.in"))
+
+  

haskell_edsl/src/Checktestdata/Options.hs

@@ -21,11 +21,17 @@ data Options = Options {
   -- | When set to 'True', whitespace changes are accepted, including heading
   --   and training whitespace, but not newlines. Be careful: extra whitespace
   --   matches greedily!
-  whitespace_ok :: Bool
+  whitespace_ok :: Bool,
+  -- | When set to 'True', print no output.
+  quiet         :: Bool,
+  -- | Path to the input, or 'Nothing' for reading from stdin
+  input_file    :: Maybe FilePath
   }
 
 -- | The default values for 'Options'
 defaultOptions :: Options
 defaultOptions = Options {
-  whitespace_ok = False
+  whitespace_ok = False,
+  quiet         = False,
+  input_file    = Nothing
   }