Make ParserFailure monadic.

Options/Applicative/BashCompletion.hs

@@ -17,7 +17,7 @@ bashCompletionParser :: Parser a -> Parser ParserFailure
 bashCompletionParser parser = complParser
   where
     failure opts = ParserFailure
-      { errMessage = \_ -> unlines opts
+      { errMessage = \progn -> unlines <$> opts progn
       , errExitCode = ExitSuccess }
 
     complParser = asum
@@ -25,15 +25,14 @@ bashCompletionParser parser = complParser
         (   bashCompletionQuery parser
         <$> (many . strOption) (long "bash-completion-word")
         <*> option (long "bash-completion-index") )
-      , ParserFailure
-          <$> (bashCompletionScript <$>
-                strOption (long "bash-completion-script"))
-          <*> pure ExitSuccess ]
+      , failure <$>
+          (bashCompletionScript <$>
+            strOption (long "bash-completion-script")) ]
 
-bashCompletionQuery :: Parser a -> [String] -> Int -> [String]
-bashCompletionQuery parser ws i = case runCompletion compl parser of
-  (Left ComplExit, SomeParser p, _) -> list_options p
-  _ -> []
+bashCompletionQuery :: Parser a -> [String] -> Int -> String -> IO [String]
+bashCompletionQuery parser ws i _ = case runCompletion compl parser of
+  (Left ComplExit, SomeParser p, _) -> return $ list_options p
+  _ -> return []
   where
     list_options = filter is_completion
                  . concat
@@ -58,8 +57,8 @@ bashCompletionQuery parser ws i = case runCompletion compl parser of
       setParser Nothing parser
       runParserFully parser (drop 1 ws')
 
-bashCompletionScript :: String -> String -> String
-bashCompletionScript prog progn = unlines
+bashCompletionScript :: String -> String -> IO [String]
+bashCompletionScript prog progn = return
   [ "_" ++ progn ++ "()"
   , "{"
   , "    local cmdline"

Options/Applicative/Extra.hs

@@ -47,9 +47,10 @@ customExecParser pprefs pinfo = do
     Left failure -> do
       progn <- getProgName
       let c = errExitCode failure
+      msg <- errMessage failure progn
       case c of
-        ExitSuccess -> putStr (errMessage failure progn)
-        _           -> hPutStr stderr (errMessage failure progn)
+        ExitSuccess -> putStr msg
+        _           -> hPutStr stderr msg
       exitWith c
 
 data Result a = Result a
@@ -68,7 +69,8 @@ execParserPure pprefs pinfo args =
     (Left msg, ctx) -> Left ParserFailure
       { errMessage = \progn
           -> with_context ctx pinfo $ \name ->
-                 parserHelpText pprefs
+                 return
+               . parserHelpText pprefs
                . add_error msg
                . add_usage name progn
       , errExitCode = ExitFailure (infoFailureCode pinfo) }

Options/Applicative/Types.hs

@@ -107,14 +107,14 @@ instance Monoid Completer where
 
 -- | Result after a parse error.
 data ParserFailure = ParserFailure
-  { errMessage :: String -> String -- ^ Function which takes the program name
-                                   -- as input and returns an error message
-  , errExitCode :: ExitCode        -- ^ Exit code to use for this error
+  { errMessage :: String -> IO String -- ^ Function which takes the program name
+                                      -- as input and returns an error message
+  , errExitCode :: ExitCode           -- ^ Exit code to use for this error
   }
 
 instance Error ParserFailure where
   strMsg msg = ParserFailure
-    { errMessage = \_ -> msg
+    { errMessage = \_ -> return msg
     , errExitCode = ExitFailure 1 }
 
 data OptHelpInfo = OptHelpInfo

tests/Tests.hs

@@ -30,7 +30,8 @@ checkHelpText name p args = do
   let result = run p args
   assertLeft result $ \(ParserFailure err code) -> do
     expected <- readFile $ "tests/" ++ name ++ ".err.txt"
-    expected @=? err name
+    msg <- err name
+    expected @=? msg
     ExitFailure 1 @=? code
 
 case_hello :: Assertion
@@ -92,10 +93,11 @@ case_show_default = do
       i = info (p <**> helper) idm
       result = run i ["--help"]
   case result of
-    Left (ParserFailure err _) ->
+    Left (ParserFailure err _) -> do
+      msg <- err "test"
       assertHasLine
         "  -n                       set count (default: 0)"
-        (err "test")
+        msg
     Right r  -> assertFailure $ "unexpected result: " ++ show r
 
 main :: IO ()