Refactor ExecOptions.

Options/Applicative/Extra.hs

@@ -1,30 +1,14 @@
 module Options.Applicative.Extra where
 
-import Control.Monad
-import Data.Default
 import Options.Applicative
 import Options.Applicative.Types
 import Options.Applicative.Builder
+import Options.Applicative.Help
 import Options.Applicative.Utils
 import System.Environment
 import System.Exit
 import System.IO
 
-data ExecOptions = ExecOptions
-  { execFullDesc :: Bool
-  , execHeader :: String
-  , execProgDesc :: String
-  , execFooter :: String
-  , execFailureCode :: Int }
-
-instance Default ExecOptions where
- def = ExecOptions
-     { execFullDesc = True
-     , execHeader = ""
-     , execProgDesc = ""
-     , execFooter = ""
-     , execFailureCode = 1 }
-
 helper :: Parser (a -> a)
 helper = nullOption
        ( long "help"
@@ -33,30 +17,21 @@ helper = nullOption
        & value id
        & hide )
 
-execParser :: ExecOptions -> Parser a -> IO a
-execParser opts p = do
+execParser :: ParserInfo a -> IO a
+execParser info = do
   args <- getArgs
+  let p = infoParser info
   case runParser p args of
     Just (a, []) -> return a
     _ -> do
-      unless (null (execHeader opts)) $
-        putStrLn $ execHeader opts ++ "\n"
       prog <- getProgName
-      usage p prog
-      unless (null (execProgDesc opts)) $
-        putStrLn $ "  " ++ execProgDesc opts
-      let desc = fullDesc p
-      when (execFullDesc opts && not (null desc)) $ do
-        putStrLn "\nCommon options:"
-        putStrLn desc
-      unless (null (execFooter opts)) $
-        putStrLn $ '\n' : execFooter opts
+      let info' = info
+            { infoHeader = vcat [infoHeader info, usage p prog] }
+      hPutStr stderr $ parserHelpText info'
       exitWith (ExitFailure 1)
 
-usage :: Parser a -> String -> IO ()
-usage p prog = hPutStrLn stderr msg
-  where
-    msg = foldr (<+>) ""
-        [ "Usage:"
-        , prog
-        , shortDesc p ]
+usage :: Parser a -> String -> String
+usage p prog = foldr (<+>) ""
+  [ "Usage:"
+  , prog
+  , shortDesc p ]

Options/Applicative/Help.hs

@@ -0,0 +1,17 @@
+module Options.Applicative.Help where
+
+import Options.Applicative
+import Options.Applicative.Types
+
+parserHelpText :: ParserInfo a -> String
+parserHelpText info = unlines
+   $ nn [infoHeader info]
+  ++ [ "  " ++ line | line <- nn [infoProgDesc info] ]
+  ++ [ line | desc <- nn [fullDesc p]
+            , line <- ["", "Common options:", desc]
+            , infoFullDesc info ]
+  ++ [ line | footer <- nn [infoFooter info]
+            , line <- ["", footer] ]
+  where
+    nn = filter (not . null)
+    p = infoParser info

Options/Applicative/Types.hs

@@ -5,6 +5,23 @@ import Control.Applicative
 import Control.Monad
 import Data.Lens.Template
 
+data ParserInfo a = ParserInfo
+  { infoParser :: Parser a
+  , infoFullDesc :: Bool
+  , infoHeader :: String
+  , infoProgDesc :: String
+  , infoFooter :: String
+  , infoFailureCode :: Int }
+
+info :: Parser a -> ParserInfo a
+info parser = ParserInfo
+  { infoParser = parser
+  , infoFullDesc = True
+  , infoHeader = ""
+  , infoProgDesc = ""
+  , infoFooter = ""
+  , infoFailureCode = 1 }
+
 data OptName = OptShort !Char
              | OptLong !String
   deriving (Eq, Ord)

Options/Applicative/Utils.hs

@@ -1,10 +1,15 @@
 module Options.Applicative.Utils where
 
+import Data.List
+
 (<+>) :: String -> String -> String
 "" <+> s = s
 s <+> "" = s
 s1 <+> s2 = s1 ++ " " ++ s2
 
+vcat :: [String] -> String
+vcat = intercalate "\n\n" . filter (not . null)
+
 tabulate :: Int -> [(String, String)] -> String
 tabulate size table = unlines
   [ "  " ++ pad size key ++ " " ++ value

example.hs

@@ -1,4 +1,4 @@
-import Options.Applicative
+import Options.Applicative.Types
 import Options.Applicative.Builder
 import Control.Applicative
 
@@ -11,12 +11,12 @@ example :: Parser User
 example = User
   <$> strOption
       ( long "name"
-      . short 'n'
-      . metavar "NAME"
-      . help "Specify a username" )
+      & short 'n'
+      & metavar "NAME"
+      & help "Specify a username" )
   <*> option
       ( long "id"
-      . short 'i'
-      . metavar "ID"
-      . value 0
-      . help "Specify the user id" )
+      & short 'i'
+      & metavar "ID"
+      & value 0
+      & help "Specify the user id" )

hello.hs

@@ -1,5 +1,4 @@
 import Control.Applicative
-import Data.Default
 import Options.Applicative.Types
 import Options.Applicative.Builder
 import Options.Applicative.Extra
@@ -18,8 +17,9 @@ greet :: Sample -> IO ()
 greet (Sample h) = putStrLn $ "Hello, " ++ h
 
 main :: IO ()
-main = execParser opts (helper <*> sample) >>= greet
-  where opts = def
-             { execFullDesc = True
-             , execProgDesc = "Print a greeting for TARGET"
-             , execHeader = "hello - a test for optparse-applicative" }
+main = execParser opts >>= greet
+  where
+    opts = (info $ helper <*> sample)
+      { infoFullDesc = True
+      , infoProgDesc = "Print a greeting for TARGET"
+      , infoHeader = "hello - a test for optparse-applicative" }

modes.hs

@@ -1,5 +1,4 @@
 import Control.Applicative
-import Data.Default
 import Options.Applicative.Types
 import Options.Applicative.Builder
 import Options.Applicative.Extra
@@ -22,4 +21,4 @@ run (Hello target) = putStrLn $ "Hello, " ++ target ++ "!"
 run Goodbye = putStrLn "Goodbye."
 
 main :: IO ()
-main = execParser def sample >>= run
+main = execParser (info sample) >>= run

optparse-applicative.cabal

@@ -16,8 +16,8 @@ library
                        Options.Applicative.Types,
                        Options.Applicative.Builder,
                        Options.Applicative.Utils,
-                       Options.Applicative.Extra
-  -- other-modules:       
+                       Options.Applicative.Extra,
+                       Options.Applicative.Help
   build-depends:       base == 4.5.*,
                        data-lens == 2.10.*,
                        data-lens-template == 2.1.*,