Complicated.hs

{-# LANGUAGE NoImplicitPrelude #-}

{-|
Module      : Options.Applicative.Complicated
Description : Simple interface to complicated program arguments.
License     : BSD-3-Clause

Simple interface to complicated program arguments.

This is a "fork" of the @optparse-simple@ package that has some workarounds for
optparse-applicative issues that become problematic with programs that have many
options and subcommands. Because it makes the interface more complex, these
workarounds are not suitable for pushing upstream to optparse-applicative.
-}

module Options.Applicative.Complicated
  ( addCommand
  , addSubCommands
  , complicatedOptions
  , complicatedParser
  ) where

import           Control.Monad.Trans.Except ( runExceptT )
import           Control.Monad.Trans.Writer ( runWriter, tell )
import           Options.Applicative
                   ( Parser, ParserFailure, ParserHelp, ParserResult (..)
                   , abortOption, command, execParserPure, footer, fullDesc
                   , handleParseResult, header, help, hsubparser, info
                   , infoOption, long, metavar, noBacktrack, prefs, progDesc
                   , short, showHelpOnEmpty
                   )
import           Options.Applicative.Builder.Extra ( showHelpText )
import           Stack.Prelude
import           Stack.Types.AddCommand ( AddCommand )
import           Stack.Types.GlobalOptsMonoid ( GlobalOptsMonoid )
import           Stack.Types.Runner ( Runner )
import           System.Environment ( getArgs )

-- | Generate and execute a complicated options parser.
complicatedOptions ::
     Version
     -- ^ numeric version
  -> Maybe String
     -- ^ version string
  -> String
     -- ^ Hpack numeric version, as string
  -> String
     -- ^ header
  -> String
     -- ^ program description (displayed between usage and options listing in
     -- the help output)
  -> String
     -- ^ footer
  -> Parser GlobalOptsMonoid
     -- ^ common settings
  -> Maybe (  ParserFailure ParserHelp
           -> [String]
           -> IO (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
           )
     -- ^ optional handler for parser failure; 'handleParseResult' is called by
     -- default
  -> AddCommand
     -- ^ commands (use 'addCommand')
  -> IO (GlobalOptsMonoid, RIO Runner ())
complicatedOptions
    numericVersion
    stringVersion
    numericHpackVersion
    h
    pd
    footerStr
    commonParser
    mOnFailure
    commandParser
  = do
    args <- getArgs
    (a, (b, c)) <- let parserPrefs = prefs $ noBacktrack <> showHelpOnEmpty
                   in  case execParserPure parserPrefs parser args of
       -- call onFailure handler if it's present and parsing options failed
      Failure f | Just onFailure <- mOnFailure -> onFailure f args
      parseResult -> handleParseResult parseResult
    pure (mappend c a, b)
 where
  parser = info
    (   helpOption
    <*> versionOptions
    <*> complicatedParser "COMMAND|FILE" commonParser commandParser
    )
    desc
  desc = fullDesc <> header h <> progDesc pd <> footer footerStr
  versionOptions =
    case stringVersion of
      Nothing -> versionOption (versionString numericVersion)
      Just s ->
            versionOption s
        <*> numericVersionOption
        <*> numericHpackVersionOption
  versionOption s =
    infoOption
      s
      (  long "version"
      <> help "Show version."
      )
  numericVersionOption =
    infoOption
      (versionString numericVersion)
      (  long "numeric-version"
      <> help "Show only version number."
      )
  numericHpackVersionOption =
    infoOption
      numericHpackVersion
      (  long "hpack-numeric-version"
      <> help "Show only Hpack's version number."
      )

-- | Add a command to the options dispatcher.
addCommand ::
     String   -- ^ command string
  -> String   -- ^ title of command
  -> String   -- ^ footer of command help
  -> (opts -> RIO Runner ())
     -- ^ constructor to wrap up command in common data type
  -> (opts -> GlobalOptsMonoid -> GlobalOptsMonoid)
     -- ^ extend common settings from local settings
  -> Parser GlobalOptsMonoid -- ^ common parser
  -> Parser opts -- ^ command parser
  -> AddCommand
addCommand cmd title footerStr constr extendCommon =
  addCommand' cmd title footerStr (\a c -> (constr a, extendCommon a c))

-- | Add a command that takes sub-commands to the options dispatcher.
addSubCommands ::
     String
     -- ^ command string
  -> String
     -- ^ title of command
  -> String
     -- ^ footer of command help
  -> Parser GlobalOptsMonoid
     -- ^ common parser
  -> AddCommand
     -- ^ sub-commands (use 'addCommand')
  -> AddCommand
addSubCommands cmd title footerStr commonParser commandParser =
  addCommand'
    cmd
    title
    footerStr
    (\(c1, (a, c2)) c3 -> (a, mconcat [c3, c2, c1]))
    commonParser
    (complicatedParser "COMMAND" commonParser commandParser)

-- | Add a command to the options dispatcher.
addCommand' ::
     String   -- ^ command string
  -> String   -- ^ title of command
  -> String   -- ^ footer of command help
  -> (opts -> GlobalOptsMonoid -> (RIO Runner (),GlobalOptsMonoid))
     -- ^ constructor to wrap up command in common data type
  -> Parser GlobalOptsMonoid -- ^ common parser
  -> Parser opts -- ^ command parser
  -> AddCommand
addCommand' cmd title footerStr constr commonParser inner =
  lift $ tell $
    command
      cmd
      ( info
          (constr <$> inner <*> commonParser)
          (progDesc title <> footer footerStr)
      )

-- | Generate a complicated options parser.
complicatedParser ::
     String
     -- ^ metavar for the sub-command
  -> Parser GlobalOptsMonoid
     -- ^ common settings
  -> AddCommand
     -- ^ commands (use 'addCommand')
  -> Parser (GlobalOptsMonoid, (RIO Runner (), GlobalOptsMonoid))
complicatedParser commandMetavar commonParser commandParser =
  (,)
    <$> commonParser
    <*> case runWriter (runExceptT commandParser) of
          (Right (), m) -> hsubparser (m <> metavar commandMetavar)
          (Left b, _) -> pure (b, mempty)

-- | Non-hidden help option.
helpOption :: Parser (a -> a)
helpOption =
  abortOption showHelpText $
       long "help"
    <> short 'h'
    <> help "Show this help text."