Make usage-/help-string behavior consistent with original docopt

Fixes docopt#32.

This makes 3 main changes to this library's behavior:

1) `pUsagePatterns` (and thus `pDocopt`) parses out the "Usage:" section
   of the helpstring as a string and returns that. The way I'm parsing
   it feels really hacky but I wasn't sure a better way to achieve it.
2) `exitWithUsage` and `exitWithUsaegMessage` now print that "short
   usage string" rather than the whole helpstring. `exitWithHelpstring`
   has been added, which prints the whole helpstring.
3) `parseArgsOrExit` automatically exits printing the helpstring if
   `longOption "help"` is present, to be more consistent with the
   original `docopt` behavior. I'm not sure this is the correct place in
   the library to put it, but it creates the intended behavior.

System/Console/Docopt/NoTH.hs

@@ -26,7 +26,7 @@ parseUsage rawUsg =
   let usg = trimEmptyLines rawUsg
   in case runParser pDocopt M.empty "Usage" usg of
     Left e       -> Left e
-    Right optfmt -> Right (Docopt optfmt usg)
+    Right (short_usg,optfmt) -> Right (Docopt optfmt short_usg usg)
 
 -- | Same as 'parseUsage', but 'exitWithUsage' on parse failure. E.g.
 --

System/Console/Docopt/Public.hs

@@ -10,6 +10,7 @@ module System.Console.Docopt.Public
     -- * Parsed usage string
     , Docopt ()
     , usage
+    , exitWithHelpstring
     , exitWithUsage
     , exitWithUsageMessage
 
@@ -47,6 +48,7 @@ import Data.Maybe (fromMaybe)
 import System.Console.Docopt.Types
 import System.Console.Docopt.ApplicativeParsec (ParseError)
 import System.Console.Docopt.OptParse
+import Control.Monad (when)
 
 
 -- | Parse command line arguments.
@@ -57,11 +59,22 @@ parseArgs parser = getArguments (optFormat parser)
 --
 -- > args <- parseArgsOrExit patterns =<< getArgs
 parseArgsOrExit :: Docopt -> [String] -> IO Arguments
-parseArgsOrExit parser argv = either (const $ exitWithUsage parser) return $ parseArgs parser argv
+parseArgsOrExit parser argv = do
+    opts <- either (const $ exitWithUsage parser) return $ parseArgs parser argv
+    when (opts `isPresent` (longOption "help")) $ do
+        exitWithHelpstring parser
+    return opts
+
 
 -- | Exit after printing usage text.
 exitWithUsage :: Docopt -> IO a
 exitWithUsage doc = do
+  putStr $ shortUsage doc
+  exitFailure
+
+-- | Exit after printing the helpstring.
+exitWithHelpstring :: Docopt -> IO a
+exitWithHelpstring doc = do
   putStr $ usage doc
   exitFailure
 

System/Console/Docopt/QQ.hs

@@ -17,15 +17,15 @@ import System.Console.Docopt.UsageParse
 import Language.Haskell.TH
 import Language.Haskell.TH.Quote
 
-parseFmt :: FilePath -> String -> Either ParseError OptFormat
+parseFmt :: FilePath -> String -> Either ParseError (String,OptFormat)
 parseFmt = runParser pDocopt M.empty
 
 docoptExp :: String -> Q Exp
 docoptExp rawUsg = do
   let usg = trimEmptyLines rawUsg
-  let mkDocopt fmt = Docopt { usage = usg, optFormat = fmt }
+  let mkDocopt short_usg fmt = Docopt { usage = usg, shortUsage = short_usg, optFormat = fmt }
   loc <- loc_filename <$> location
-  case mkDocopt <$> parseFmt loc usg of
+  case uncurry mkDocopt <$> parseFmt loc usg of
     Left err     -> fail $ show err
     Right parser -> [| parser |]
 

System/Console/Docopt/Types.hs

@@ -103,6 +103,8 @@ type Arguments = Map Option ArgValue
 
 -- | An abstract data type which represents Docopt usage patterns.
 data Docopt = Docopt { optFormat :: OptFormat
+                     -- | Retrieve the "Usage:" section of the usage string.
+                     , shortUsage :: String
                      -- | Retrieve the original usage string.
                      , usage :: String
-                     }
+                     } deriving(Show)

System/Console/Docopt/UsageParse.hs

@@ -145,13 +145,16 @@ pUsageLine =
         many1 (satisfy (not . isSpace)) -- prog name
         pLine
 
-pUsagePatterns :: CharParser OptInfoMap OptPattern
+pUsagePatterns :: CharParser OptInfoMap (String,OptPattern)
 pUsagePatterns = do
         many (notFollowedBy pUsageHeader >> anyChar)
-        pUsageHeader
+        header <- pUsageHeader
         optionalEndline
+        usageLines_str <- fmap (unlines . (header:)) . lookAhead $ many $ try $ do
+            lookAhead $ pUsageLine
+            manyTill anyChar $ try $ eof <|> (const () <$> endline)
         usageLines <- pUsageLine `sepEndBy` endline
-        return $ flatten . OneOf $ usageLines
+        return $ (usageLines_str, flatten . OneOf $ usageLines)
 
 -- * Option Synonyms & Defaults Parsers
 
@@ -204,16 +207,16 @@ pOptDescriptions = do
 -- | Main usage parser: parses all of the usage lines into an Exception,
 --   and all of the option descriptions along with any accompanying
 --   defaults, and returns both in a tuple
-pDocopt :: CharParser OptInfoMap OptFormat
+pDocopt :: CharParser OptInfoMap (String,OptFormat)
 pDocopt = do
-    optPattern <- pUsagePatterns
+    (usage_str,optPattern) <- pUsagePatterns
     optInfoMap <- pOptDescriptions
     let optPattern' = eagerSort $ expectSynonyms optInfoMap optPattern
         saveCanRepeat pat el minfo = case minfo of
           (Just info) -> Just $ info {isRepeated = canRepeat pat el}
           (Nothing)   -> Just $ (fromSynList []) {isRepeated = canRepeat pat el}
         optInfoMap' = alterAllWithKey (saveCanRepeat optPattern') (atoms optPattern') optInfoMap
-    return (optPattern', optInfoMap')
+    return (usage_str,(optPattern', optInfoMap'))
 
 
 -- ** Pattern transformation & analysis

examples/NavalFate/Shared.hs

@@ -55,5 +55,3 @@ navalFateDispatchArgs doc opts = do
     exitSuccess
   when (opts `isPresent` (longOption "version")) $ do
     putStrLn "Naval Fate v0.0.0.0.0.1.0"
-  when (opts `isPresent` (longOption "help")) $ do
-    exitWithUsage doc

test/LangAgnosticTests.hs

@@ -116,7 +116,7 @@ testsFromDocoptSpecFile name testFile ignore =
 
     let (optFormat, docParseMsg) = case runParser pDocopt M.empty "Usage" usage of
           Left e -> ((Sequence [], M.empty), "Couldn't parse usage text")
-          Right o -> (o, "")
+          Right (_,o) -> (o, "")
 
     let groupDescLines = [
             docParseMsg,