Parse options with optparse-applicative

Also ddd shelltestrunner tests.

Author: ffaf1

exe/Main.hs

@@ -1,6 +1,8 @@
 -- (C)  vasylp https://github.com/vasylp/hgettext/blob/master/src/hgettext.hs
 
-import qualified Language.Haskell.Exts as H 
+import qualified Language.Haskell.Exts as H
+
+import Options
 
 import System.Environment
 import System.Console.GetOpt
@@ -21,39 +23,8 @@ import Data.Version (showVersion)
 version = undefined
 -- import Paths_haskell_gettext (version)
 
-data Options = Options {
-      outputFile :: String,
-      keywords :: [String],
-      printVersion :: Bool
-    } deriving Show
-
-options :: [OptDescr (Options->Options)]
-options = 
-    [
-     Option ['o'] ["output"] 
-                (ReqArg (\o opts -> opts {outputFile = o}) "FILE") 
-                "write output to specified file",
-     Option ['d'] ["default-domain"] 
-            (ReqArg (\d opts -> opts {outputFile = d ++ ".po"}) "NAME")
-            "use NAME.po instead of messages.po",
-     Option ['k'] ["keyword"] 
-            (ReqArg (\d opts -> opts {keywords = d: keywords opts}) "WORD")
-            "function names, in which searched words are wrapped. Can be used multiple times, for multiple funcitons",
-     Option [] ["version"]
-            (NoArg (\opts -> opts {printVersion = True}))
-            "print version of hgettexts"
-    ]
-
-
-defaultOptions = Options "messages.po" ["__", "lprintf"] False
-
-parseArgs :: [String] -> IO (Options, [String])
-parseArgs args = 
-    case getOpt Permute options args of
-      (o, n, []) -> return (foldl (flip id) defaultOptions o, n)
-      (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
-    where header = "Usage: hgettext [OPTION] [INPUTFILE] ..."
-
+-- xxx add default options
+-- defaultOptions = Options "messages.po" ["__", "lprintf"] False
 
 toTranslate :: [String] -> H.ParseResult (H.Module H.SrcSpanInfo) -> [(H.SrcSpanInfo, String)]
 toTranslate f (H.ParseOk z) = nub [ (loc, s) | H.App _ (H.Var _ (H.UnQual _ (H.Ident _ x))) (H.Lit _ (H.String loc s _)) <- universeBi z, x `elem` f]
@@ -95,18 +66,16 @@ formatPotFile lines = do
                 "\"Content-Transfer-Encoding: 8bit\\n\"",
                 ""]
 
-process :: Options -> [String] -> IO ()
-process Options{printVersion = True} _ = 
+process :: Options -> IO ()
+process Options{printVersion = True} =
     putStrLn $ "hgettext, version " ++ (showVersion version)
-
-process opts fl = do
-  t <- mapM read' fl
+process opts = do
+  t <- mapM read' (inputFiles opts)
   pot <- formatPotFile $ map (\(n,c) -> formatMessages n $ toTranslate (keywords opts) c) t
   writeFile (outputFile opts) pot
     where read' "-" = getContents >>= \c -> return ("-", H.parseFileContents c)
           read' f = H.parseFile f >>= \m -> return (f, m)
 
-main = 
-    getArgs >>= parseArgs >>= uncurry process
-
-
+main = do
+    opts <- parseOptions
+    process opts

exe/Options.hs

@@ -0,0 +1,67 @@
+module Options (
+        Options(..),
+        parseOptions
+    )
+        where
+
+import Options.Applicative
+
+import qualified System.FilePath as FP
+
+data Options = Options {
+      inputFiles :: [FilePath],
+      outputFile :: FilePath,
+      keywords :: [String],
+      printVersion :: Bool
+    } deriving Show
+
+parseOptions :: IO Options
+parseOptions = execParser infoOpts
+
+-------------------------------------------------------------------------------
+-- Parsers/properties
+
+-- xxx test help
+infoOpts :: ParserInfo Options
+infoOpts = info (options <**> helper)
+  ( fullDesc
+  <> progDesc "Extract translatable strings from Haskell source files."
+  <> header "hello - a test for optparse-applicative" )
+
+options :: Parser Options
+options = Options <$> inputs <*> outfile <*> many keyword <*> version
+
+inputs :: Parser [FilePath]
+inputs = many (argument str (metavar "PATH..."))
+
+outfile :: Parser FilePath
+outfile = output <|> ((FP.<.> "po") <$> defaultDomain) <|> pure "messages.po"
+    where
+        output :: Parser FilePath
+        output = strOption
+            ( long "output"
+            <> short 'o'
+            <> metavar "FILE"
+            <> help "Write output to specified file." )
+
+        defaultDomain :: Parser FilePath
+        defaultDomain = strOption
+            ( long "default-domain"
+            <> short 'd'
+            <> metavar "NAME"
+            <> help "Use NAME.po instead of messages.po." )
+
+keyword :: Parser String
+keyword = strOption
+                ( long "keyword"
+                <> short 'k'
+                <> metavar "WORD"
+                <> help "function names, in which searched words are \
+                        \wrapped. Can be used multiple times, for multiple \
+                        \funcitons." )
+
+version :: Parser Bool
+version = switch
+            ( long "version"
+            <> short 'v'
+            <> help "Print version of hgettext" )

haskell-gettext.cabal

@@ -62,9 +62,11 @@ library
 executable hgettext
   import:            shared
   main-is:           Main.hs
+  other-modules:     Options
   build-depends:     filepath >= 1.4 && < 1.6,
                      haskell-src-exts >= 1.18 && < 1.24,
-                     old-locale >= 1.0 && < 1.1
+                     old-locale >= 1.0 && < 1.1,
+                     optparse-applicative >= 0.18.1 && < 0.19,
                      time >= 1.5.0 && < 1.13,
                      uniplate >= 1.6.12 && < 1.7,
   hs-source-dirs:    exe/

run-tests.sh

@@ -0,0 +1,33 @@
+#! /bin/bash
+set -e
+
+## TODO clean artifacts regardless
+
+### Helpers
+
+# Clean stale artifacts from previous runs.
+function cleanArtifacts {
+    echo "Cleaning artifacts…"
+    find test/shelltest/ -type f \
+        -regextype posix-egrep -regex ".*\.po" -delete
+}
+
+
+### Program
+
+clear
+
+if ! which shelltest > /dev/null; then
+  echo "shelltest not installed, install it (shelltestrunner)!"
+  exit 1
+fi
+
+cabal build hgettext
+Bin=$(cabal list-bin hgettext)
+
+
+# Run all tests, and clean before (always) and after (only if shelltest
+# exits without errors).
+cleanArtifacts
+shelltest --color --execdir --with "$Bin" test/shelltest/
+cleanArtifacts

test/shelltest/exceptions/empty.test

@@ -0,0 +1,9 @@
+# 1.Print helpful text on missing input.
+$ hgettext
+hgettext: missing arguments
+>= 0
+
+# 2.Do not create messages.po on missing input.
+$ hgettext && ls
+> /!messages.po/
+>= 0

test/shelltest/options/Menu.hs

@@ -0,0 +1,4 @@
+module Menu where
+
+intro :: Loc a
+intro = __ "Welcome!"

test/shelltest/options/options.test

@@ -0,0 +1,16 @@
+# Get `output` argument.
+# 1. Get `output` argument.
+$ hgettext --output out.po && ls
+> /out.po/
+
+# 2. Get `output` argument (short).
+$ hgettext -o out.po && ls
+> /out.po/
+
+# 3. Get `default domain` argument.
+$ hgettext --default-domain dom && ls
+> /dom.po/
+
+# 3. Get `default domain` argument (short).
+$ hgettext -d dom && ls
+> /dom.po/